Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | merge [trunk] |
|---|---|
| Timelines: | family | ancestors | descendants | both | bch_sign_and_width |
| Files: | files | file ages | folders |
| SHA3-256: |
ab1626102064c57d0f4b9dd1ac36f8aa |
| User & Date: | bch 2022-09-21 17:50:17.306 |
Context
|
2022-09-21
| ||
| 18:46 | various break-fix measures check-in: eb68153185 user: bch tags: bch_sign_and_width | |
| 17:50 | merge [trunk] check-in: ab16261020 user: bch tags: bch_sign_and_width | |
|
2022-09-15
| ||
| 16:45 | Remove tilde expansion from docs. Fix comments that referenced the same. check-in: cc20621a67 user: apnadkarni tags: trunk, main | |
|
2022-05-15
| ||
| 23:06 | merge [trunk] check-in: ef75766f09 user: bch tags: bch_sign_and_width | |
Changes
Changes to .fossil-settings/ignore-glob.
| ︙ | ︙ | |||
20 21 22 23 24 25 26 | */config.status */tclConfig.sh */tclsh* */tcltest* */versions.vc */version.vc */libtcl.vfs | | > | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | */config.status */tclConfig.sh */tclsh* */tcltest* */versions.vc */version.vc */libtcl.vfs */libtcl*.zip */tclUuid.h html libtommath/bn.ilg libtommath/bn.ind libtommath/pretty.build libtommath/tommath.src libtommath/*.log libtommath/*.pdf |
| ︙ | ︙ |
Added .github/dependabot.yml.
> > > > > > | 1 2 3 4 5 6 |
version: 2
updates:
- package-ecosystem: "github-actions"
directory: "/"
schedule:
interval: "weekly"
|
Changes to .github/workflows/linux-build.yml.
1 2 3 4 | name: Linux on: [push] jobs: gcc: | > > | | | 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 |
name: Linux
on: [push]
permissions:
contents: read
jobs:
gcc:
runs-on: ubuntu-22.04
strategy:
matrix:
cfgopt:
- ""
- "CFLAGS=-DTCL_UTF_MAX=3"
- "CFLAGS=-DTCL_NO_DEPRECATED=1"
- "--disable-shared"
- "--enable-symbols"
- "--enable-symbols=mem"
- "--enable-symbols=all"
defaults:
run:
shell: bash
working-directory: unix
steps:
- name: Checkout
uses: actions/checkout@v3
- name: Prepare
run: |
touch tclStubInit.c tclOOStubInit.c tclOOScript.h
working-directory: generic
- name: Configure ${{ matrix.cfgopt }}
run: |
mkdir "${HOME}/install dir"
|
| ︙ | ︙ |
Changes to .github/workflows/mac-build.yml.
1 2 3 4 5 6 7 8 9 10 11 |
name: macOS
on: [push]
jobs:
xcode:
runs-on: macos-11
defaults:
run:
shell: bash
working-directory: macosx
steps:
- name: Checkout
| > > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
name: macOS
on: [push]
permissions:
contents: read
jobs:
xcode:
runs-on: macos-11
defaults:
run:
shell: bash
working-directory: macosx
steps:
- name: Checkout
uses: actions/checkout@v3
- name: Prepare
run: |
touch tclStubInit.c tclOOStubInit.c tclOOScript.h
working-directory: generic
- name: Build
run: make all
env:
|
| ︙ | ︙ | |||
35 36 37 38 39 40 41 |
- "--enable-symbols=all"
defaults:
run:
shell: bash
working-directory: unix
steps:
- name: Checkout
| | | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 |
- "--enable-symbols=all"
defaults:
run:
shell: bash
working-directory: unix
steps:
- name: Checkout
uses: actions/checkout@v3
- name: Prepare
run: |
touch tclStubInit.c tclOOStubInit.c tclOOScript.h
mkdir "$HOME/install dir"
working-directory: generic
- name: Configure ${{ matrix.cfgopt }}
# Note that macOS is always a 64 bit platform
|
| ︙ | ︙ |
Changes to .github/workflows/onefiledist.yml.
1 2 3 4 5 |
name: Build Binaries
on: [push]
jobs:
linux:
name: Linux
| > > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
name: Build Binaries
on: [push]
permissions:
contents: read
jobs:
linux:
name: Linux
runs-on: ubuntu-20.04
defaults:
run:
shell: bash
steps:
- name: Checkout
uses: actions/checkout@v3
- name: Prepare
run: |
touch generic/tclStubInit.c generic/tclOOStubInit.c
mkdir 1dist
echo "VER_PATH=$(cd tools; pwd)/addVerToFile.tcl" >> $GITHUB_ENV
working-directory: .
- name: Configure
|
| ︙ | ︙ | |||
28 29 30 31 32 33 34 |
- name: Package
run: |
cp ../unix/tclsh tclsh${TCL_PATCHLEVEL}_snapshot
chmod +x tclsh${TCL_PATCHLEVEL}_snapshot
tar -cf tclsh${TCL_PATCHLEVEL}_snapshot.tar tclsh${TCL_PATCHLEVEL}_snapshot
working-directory: 1dist
- name: Upload
| | | | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
- name: Package
run: |
cp ../unix/tclsh tclsh${TCL_PATCHLEVEL}_snapshot
chmod +x tclsh${TCL_PATCHLEVEL}_snapshot
tar -cf tclsh${TCL_PATCHLEVEL}_snapshot.tar tclsh${TCL_PATCHLEVEL}_snapshot
working-directory: 1dist
- name: Upload
uses: actions/upload-artifact@v3
with:
name: Tclsh ${{ env.TCL_PATCHLEVEL }} Linux single-file build (snapshot)
path: 1dist/*.tar
macos:
name: macOS
runs-on: macos-11
defaults:
run:
shell: bash
steps:
- name: Checkout
uses: actions/checkout@v3
- name: Checkout create-dmg
uses: actions/checkout@v3
with:
repository: create-dmg/create-dmg
ref: v1.0.8
path: create-dmg
- name: Prepare
run: |
mkdir 1dist
|
| ︙ | ︙ | |||
90 91 92 93 94 95 96 |
--volname "Tcl $TCL_PATCHLEVEL (snapshot)" \
--window-pos 200 120 \
--window-size 800 400 \
"Tcl-$TCL_PATCHLEVEL-(snapshot).dmg" \
"contents/"
working-directory: 1dist
- name: Upload
| | | | 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 |
--volname "Tcl $TCL_PATCHLEVEL (snapshot)" \
--window-pos 200 120 \
--window-size 800 400 \
"Tcl-$TCL_PATCHLEVEL-(snapshot).dmg" \
"contents/"
working-directory: 1dist
- name: Upload
uses: actions/upload-artifact@v3
with:
name: Tclsh ${{ env.TCL_PATCHLEVEL }} macOS single-file build (snapshot)
path: 1dist/*.dmg
win:
name: Windows
runs-on: windows-2019
defaults:
run:
shell: msys2 {0}
env:
CC: gcc
CFGOPT: --disable-symbols --disable-shared
steps:
- name: Install MSYS2
uses: msys2/setup-msys2@v2
with:
msystem: UCRT64
install: git mingw-w64-ucrt-x86_64-toolchain make zip
- name: Checkout
uses: actions/checkout@v3
- name: Prepare
run: |
touch generic/tclStubInit.c generic/tclOOStubInit.c
echo "VER_PATH=$(cd tools; pwd)/addVerToFile.tcl" >> $GITHUB_ENV
mkdir 1dist
working-directory: .
- name: Configure
|
| ︙ | ︙ | |||
134 135 136 137 138 139 140 |
./tclsh*.exe $VER_PATH $GITHUB_ENV
working-directory: win
- name: Set Executable Name
run: |
cp ../win/tclsh*.exe tclsh${TCL_PATCHLEVEL}_snapshot.exe
working-directory: 1dist
- name: Upload
| | | 136 137 138 139 140 141 142 143 144 145 146 |
./tclsh*.exe $VER_PATH $GITHUB_ENV
working-directory: win
- name: Set Executable Name
run: |
cp ../win/tclsh*.exe tclsh${TCL_PATCHLEVEL}_snapshot.exe
working-directory: 1dist
- name: Upload
uses: actions/upload-artifact@v3
with:
name: Tclsh ${{ env.TCL_PATCHLEVEL }} Windows single-file build (snapshot)
path: '1dist/*_snapshot.exe'
|
Changes to .github/workflows/win-build.yml.
1 2 3 4 5 6 7 8 9 |
name: Windows
on: [push]
env:
ERROR_ON_FAILURES: 1
jobs:
msvc:
runs-on: windows-2022
defaults:
run:
| > > | 1 2 3 4 5 6 7 8 9 10 11 |
name: Windows
on: [push]
permissions:
contents: read
env:
ERROR_ON_FAILURES: 1
jobs:
msvc:
runs-on: windows-2022
defaults:
run:
|
| ︙ | ︙ | |||
17 18 19 20 21 22 23 |
- "CHECKS=nodep"
- "OPTS=static"
- "OPTS=symbols"
- "OPTS=symbols STATS=compdbg,memdbg"
# Using powershell means we need to explicitly stop on failure
steps:
- name: Checkout
| | | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
- "CHECKS=nodep"
- "OPTS=static"
- "OPTS=symbols"
- "OPTS=symbols STATS=compdbg,memdbg"
# Using powershell means we need to explicitly stop on failure
steps:
- name: Checkout
uses: actions/checkout@v3
- name: Init MSVC
uses: ilammy/msvc-dev-cmd@v1
- name: Build ${{ matrix.cfgopt }}
run: |
&nmake -f makefile.vc ${{ matrix.cfgopt }} all
if ($lastexitcode -ne 0) {
throw "nmake exit code: $lastexitcode"
|
| ︙ | ︙ | |||
62 63 64 65 66 67 68 |
steps:
- name: Install MSYS2
uses: msys2/setup-msys2@v2
with:
msystem: MINGW64
install: git mingw-w64-x86_64-toolchain make
- name: Checkout
| | | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 |
steps:
- name: Install MSYS2
uses: msys2/setup-msys2@v2
with:
msystem: MINGW64
install: git mingw-w64-x86_64-toolchain make
- name: Checkout
uses: actions/checkout@v3
- name: Prepare
run: |
touch tclStubInit.c tclOOStubInit.c tclOOScript.h
mkdir "${HOME}/install dir"
working-directory: generic
- name: Configure ${{ matrix.cfgopt }}
run: |
|
| ︙ | ︙ |
Changes to .gitignore.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 | config.status config.status.lineno html manifest.uuid _FOSSIL_ */tclConfig.sh */tclsh* | | | > | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | config.status config.status.lineno html manifest.uuid _FOSSIL_ */tclConfig.sh */tclsh* */tcltest */versions.vc */version.vc */libtcl.vfs */libtcl*.zip */tclUuid.h libtommath/bn.ilg libtommath/bn.ind libtommath/pretty.build libtommath/tommath.src libtommath/*.log libtommath/*.pdf libtommath/*.pl |
| ︙ | ︙ |
Changes to compat/stdlib.h.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 | #ifndef _STDLIB #define _STDLIB extern void abort(void); extern double atof(const char *string); extern int atoi(const char *string); extern long atol(const char *string); | | | | | > | > > > | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | #ifndef _STDLIB #define _STDLIB extern void abort(void); extern double atof(const char *string); extern int atoi(const char *string); extern long atol(const char *string); extern void * calloc(unsigned long numElements, unsigned long size); extern void exit(int status); extern void free(void *blockPtr); extern char * getenv(const char *name); extern void * malloc(unsigned long numBytes); extern void qsort(void *base, unsigned long n, unsigned long size, int (*compar)( const void *element1, const void *element2)); extern void * realloc(void *ptr, unsigned long numBytes); extern char * realpath(const char *path, char *resolved_path); extern int mkstemps(char *templ, int suffixlen); extern int mkstemp(char *templ); extern char * mkdtemp(char *templ); extern long strtol(const char *string, char **endPtr, int base); extern unsigned long strtoul(const char *string, char **endPtr, int base); #endif /* _STDLIB */ |
Changes to doc/AddErrInfo.3.
| ︙ | ︙ | |||
50 51 52 53 54 55 56 | .AP "const char" *message in For \fBTcl_AddErrorInfo\fR, this is a conventional C string to append to the \fB\-errorinfo\fR return option. For \fBTcl_AddObjErrorInfo\fR, this points to the first byte of an array of \fIlength\fR bytes containing a string to append to the \fB\-errorinfo\fR return option. This byte array may contain embedded null bytes | | | 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 | .AP "const char" *message in For \fBTcl_AddErrorInfo\fR, this is a conventional C string to append to the \fB\-errorinfo\fR return option. For \fBTcl_AddObjErrorInfo\fR, this points to the first byte of an array of \fIlength\fR bytes containing a string to append to the \fB\-errorinfo\fR return option. This byte array may contain embedded null bytes unless \fIlength\fR is TCL_INDEX_NONE. .AP Tcl_Obj *objPtr in A message to be appended to the \fB\-errorinfo\fR return option in the form of a Tcl_Obj value. .AP size_t length in The number of bytes to copy from \fImessage\fR when appending to the \fB\-errorinfo\fR return option. If TCL_INDEX_NONE, all bytes up to the first null byte are used. |
| ︙ | ︙ | |||
72 73 74 75 76 77 78 | \fBva_start\fR, and cleared using \fBva_end\fR. .AP int lineNum The line number of a script where an error occurred. .AP "const char" *script in Pointer to first character in script containing command (must be <= command) .AP "const char" *command in Pointer to first character in command that generated the error | | | | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 | \fBva_start\fR, and cleared using \fBva_end\fR. .AP int lineNum The line number of a script where an error occurred. .AP "const char" *script in Pointer to first character in script containing command (must be <= command) .AP "const char" *command in Pointer to first character in command that generated the error .AP size_t commandLength in Number of bytes in command; TCL_INDEX_NONE means use all bytes up to first null byte .BE .SH DESCRIPTION .PP The \fBTcl_SetReturnOptions\fR and \fBTcl_GetReturnOptions\fR routines expose the same capabilities as the \fBreturn\fR and \fBcatch\fR commands, respectively, in the form of a C interface. .PP |
| ︙ | ︙ | |||
223 224 225 226 227 228 229 | \fBTcl_AddObjErrorInfo\fR is nearly identical to \fBTcl_AddErrorInfo\fR, except that it has an additional \fIlength\fR argument. This allows the \fImessage\fR string to contain embedded null bytes. This is essentially never a good idea. If the \fImessage\fR needs to contain the null character \fBU+0000\fR, Tcl's usual internal encoding rules should be used to avoid the need for a null byte. If the \fBTcl_AddObjErrorInfo\fR | | | 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 | \fBTcl_AddObjErrorInfo\fR is nearly identical to \fBTcl_AddErrorInfo\fR, except that it has an additional \fIlength\fR argument. This allows the \fImessage\fR string to contain embedded null bytes. This is essentially never a good idea. If the \fImessage\fR needs to contain the null character \fBU+0000\fR, Tcl's usual internal encoding rules should be used to avoid the need for a null byte. If the \fBTcl_AddObjErrorInfo\fR interface is used at all, it should be with a TCL_INDEX_NONE \fIlength\fR value. .PP The procedure \fBTcl_SetObjErrorCode\fR is used to set the \fB\-errorcode\fR return option to the list value \fIerrorObjPtr\fR built up by the caller. \fBTcl_SetObjErrorCode\fR is typically invoked just before returning an error. If an error is returned without calling \fBTcl_SetObjErrorCode\fR or |
| ︙ | ︙ |
Changes to doc/ByteArrObj.3.
| ︙ | ︙ | |||
39 40 41 42 43 44 45 | .AP Tcl_Obj *objPtr in/out For \fBTcl_SetByteArrayObj\fR, this points to an unshared value to be overwritten by a byte-array value. For \fBTcl_GetBytesFromObj\fR, \fBTcl_GetByteArrayFromObj\fR and \fBTcl_SetByteArrayLength\fR, this points to the value from which to extract an array of bytes. .AP Tcl_Interp *interp in Interpreter to use for error reporting. | | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | .AP Tcl_Obj *objPtr in/out For \fBTcl_SetByteArrayObj\fR, this points to an unshared value to be overwritten by a byte-array value. For \fBTcl_GetBytesFromObj\fR, \fBTcl_GetByteArrayFromObj\fR and \fBTcl_SetByteArrayLength\fR, this points to the value from which to extract an array of bytes. .AP Tcl_Interp *interp in Interpreter to use for error reporting. .AP "size_t \&| int" *numBytesPtr out Points to space where the number of bytes in the array may be written. Caller may pass NULL when it does not need this information. .BE .SH DESCRIPTION .PP These routines are used to create, modify, store, transfer, and retrieve |
| ︙ | ︙ |
Changes to doc/Class.3.
| ︙ | ︙ | |||
77 78 79 80 81 82 83 | .AP "const char" *name in The name of the object to create, or NULL if a new unused name is to be automatically selected. .AP "const char" *nsName in The name of the namespace to create for the object's private use, or NULL if a new unused name is to be automatically selected. The namespace must not already exist. | | | | 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 | .AP "const char" *name in The name of the object to create, or NULL if a new unused name is to be automatically selected. .AP "const char" *nsName in The name of the namespace to create for the object's private use, or NULL if a new unused name is to be automatically selected. The namespace must not already exist. .AP size_t objc in The number of elements in the \fIobjv\fR array. .AP "Tcl_Obj *const" *objv in The arguments to the command to create the instance of the class. .AP size_t skip in The number of arguments at the start of the argument array, \fIobjv\fR, that are not arguments to any constructors. This allows the generation of correct error messages even when complicated calling patterns are used (e.g., via the \fBnext\fR command). .AP Tcl_ObjectMetadataType *metaTypePtr in The type of \fImetadata\fR being set with \fBTcl_ClassSetMetadata\fR or retrieved with \fBTcl_ClassGetMetadata\fR. |
| ︙ | ︙ |
Changes to doc/Concat.3.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 | .nf \fB#include <tcl.h>\fR .sp const char * \fBTcl_Concat\fR(\fIargc, argv\fR) .SH ARGUMENTS .AS "const char *const" argv[] | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | .nf \fB#include <tcl.h>\fR .sp const char * \fBTcl_Concat\fR(\fIargc, argv\fR) .SH ARGUMENTS .AS "const char *const" argv[] .AP size_t argc in Number of strings. .AP "const char *const" argv[] in Array of strings to concatenate. Must have \fIargc\fR entries. .BE .SH DESCRIPTION .PP |
| ︙ | ︙ |
Changes to doc/CrtAlias.3.
| ︙ | ︙ | |||
68 69 70 71 72 73 74 | below). .AP "const char" *childCmd in Name of source command for alias. .AP Tcl_Interp *targetInterp in Interpreter that contains the target command for an alias. .AP "const char" *targetCmd in Name of target command for alias in \fItargetInterp\fR. | | | | 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 | below). .AP "const char" *childCmd in Name of source command for alias. .AP Tcl_Interp *targetInterp in Interpreter that contains the target command for an alias. .AP "const char" *targetCmd in Name of target command for alias in \fItargetInterp\fR. .AP size_t argc in Count of additional arguments to pass to the alias command. .AP "const char *const" *argv in Vector of strings, the additional arguments to pass to the alias command. This storage is owned by the caller. .AP size_t objc in Count of additional value arguments to pass to the aliased command. .AP Tcl_Obj **objv in Vector of Tcl_Obj structures, the additional value arguments to pass to the aliased command. This storage is owned by the caller. .AP Tcl_Interp **targetInterpPtr in Pointer to location to store the address of the interpreter where a target |
| ︙ | ︙ |
Changes to doc/CrtChannel.3.
| ︙ | ︙ | |||
132 133 134 135 136 137 138 | The channel to operate on. .AP int direction in \fBTCL_READABLE\fR means the input handle is wanted; \fBTCL_WRITABLE\fR means the output handle is wanted. .AP void **handlePtr out Points to the location where the desired OS-specific handle should be stored. | | | 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 | The channel to operate on. .AP int direction in \fBTCL_READABLE\fR means the input handle is wanted; \fBTCL_WRITABLE\fR means the output handle is wanted. .AP void **handlePtr out Points to the location where the desired OS-specific handle should be stored. .AP size_t size in The size, in bytes, of buffers to allocate in this channel. .AP int mask in An OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR and \fBTCL_EXCEPTION\fR that indicates events that have occurred on this channel. .AP Tcl_Interp *interp in Current interpreter. (can be NULL) |
| ︙ | ︙ | |||
526 527 528 529 530 531 532 | .PP The \fIwideSeekProc\fR field contains the address of a function called by the generic layer to move the access point at which subsequent input or output operations will be applied. \fIWideSeekProc\fR must match the following prototype: .PP .CS | | | | 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 |
.PP
The \fIwideSeekProc\fR field contains the address of a function called by the
generic layer to move the access point at which subsequent input or output
operations will be applied. \fIWideSeekProc\fR must match the following
prototype:
.PP
.CS
typedef long long \fBTcl_DriverWideSeekProc\fR(
void *\fIinstanceData\fR,
long long \fIoffset\fR,
int \fIseekMode\fR,
int *\fIerrorCodePtr\fR);
.CE
.PP
The \fIinstanceData\fR argument is the same as the value given to
\fBTcl_CreateChannel\fR when this channel was created. \fIOffset\fR and
\fIseekMode\fR have the same meaning as for the \fBTcl_Seek\fR
|
| ︙ | ︙ |
Changes to doc/CrtChnlHdlr.3.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | .AS Tcl_ChannelProc clientData .AP Tcl_Channel channel in Tcl channel such as returned by \fBTcl_CreateChannel\fR. .AP int mask in Conditions under which \fIproc\fR should be called: OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR and \fBTCL_EXCEPTION\fR. Specify a zero value to temporarily disable an existing handler. | | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | .AS Tcl_ChannelProc clientData .AP Tcl_Channel channel in Tcl channel such as returned by \fBTcl_CreateChannel\fR. .AP int mask in Conditions under which \fIproc\fR should be called: OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR and \fBTCL_EXCEPTION\fR. Specify a zero value to temporarily disable an existing handler. .AP Tcl_ChannelProc *proc in Procedure to invoke whenever the channel indicated by \fIchannel\fR meets the conditions specified by \fImask\fR. .AP void *clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION .PP |
| ︙ | ︙ |
Changes to doc/CrtObjCmd.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_CreateObjCommand 3 8.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | > > > | 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 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_CreateObjCommand 3 8.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_CreateObjCommand, Tcl_CreateObjCommand2, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj \- implement new commands in C .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Command \fBTcl_CreateObjCommand\fR(\fIinterp, cmdName, proc, clientData, deleteProc\fR) .sp Tcl_Command \fBTcl_CreateObjCommand2\fR(\fIinterp, cmdName, proc2, clientData, deleteProc\fR) .sp int \fBTcl_DeleteCommand\fR(\fIinterp, cmdName\fR) .sp int \fBTcl_DeleteCommandFromToken\fR(\fIinterp, token\fR) .sp int |
| ︙ | ︙ | |||
39 40 41 42 43 44 45 | .sp void \fBTcl_GetCommandFullName\fR(\fIinterp, token, objPtr\fR) .sp Tcl_Command \fBTcl_GetCommandFromObj\fR(\fIinterp, objPtr\fR) .sp | < < < < < < < > > > | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | .sp void \fBTcl_GetCommandFullName\fR(\fIinterp, token, objPtr\fR) .sp Tcl_Command \fBTcl_GetCommandFromObj\fR(\fIinterp, objPtr\fR) .sp .SH ARGUMENTS .AS Tcl_CmdDeleteProc *deleteProc in/out .AP Tcl_Interp *interp in Interpreter in which to create a new command or that contains a command. .AP "const char" *cmdName in Name of command. .AP Tcl_ObjCmdProc *proc in Implementation of the new command: \fIproc\fR will be called whenever \fIcmdName\fR is invoked as a command. .AP Tcl_ObjCmdProc2 *proc2 in Implementation of the new command: \fIproc2\fR will be called whenever \fIcmdName\fR is invoked as a command. .AP void *clientData in Arbitrary one-word value to pass to \fIproc\fR and \fIdeleteProc\fR. .AP Tcl_CmdDeleteProc *deleteProc in Procedure to call before \fIcmdName\fR is deleted from the interpreter; allows for command-specific cleanup. If NULL, then no procedure is called before the command is deleted. .AP Tcl_Command token in |
| ︙ | ︙ | |||
176 177 178 179 180 181 182 183 184 185 186 187 188 189 |
.CS
typedef void \fBTcl_CmdDeleteProc\fR(
void *\fIclientData\fR);
.CE
.PP
The \fIclientData\fR argument will be the same as the \fIclientData\fR
argument passed to \fBTcl_CreateObjCommand\fR.
.PP
\fBTcl_DeleteCommand\fR deletes a command from a command interpreter.
Once the call completes, attempts to invoke \fIcmdName\fR in
\fIinterp\fR will result in errors.
If \fIcmdName\fR is not bound as a command in \fIinterp\fR then
\fBTcl_DeleteCommand\fR does nothing and returns -1; otherwise
it returns 0.
| > > > > > > > > > > > | 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 |
.CS
typedef void \fBTcl_CmdDeleteProc\fR(
void *\fIclientData\fR);
.CE
.PP
The \fIclientData\fR argument will be the same as the \fIclientData\fR
argument passed to \fBTcl_CreateObjCommand\fR.
.PP
\fBTcl_CreateObjCommand2\fR does the same as \fBTcl_CreateObjCommand\fR,
except its \fIproc2\fR argument is of type \fBTcl_ObjCmdProc2\fR.
.PP
.CS
typedef int \fBTcl_ObjCmdProc2\fR(
void *\fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
size_t \fIobjc\fR,
Tcl_Obj *const \fIobjv\fR[]);
.CE
.PP
\fBTcl_DeleteCommand\fR deletes a command from a command interpreter.
Once the call completes, attempts to invoke \fIcmdName\fR in
\fIinterp\fR will result in errors.
If \fIcmdName\fR is not bound as a command in \fIinterp\fR then
\fBTcl_DeleteCommand\fR does nothing and returns -1; otherwise
it returns 0.
|
| ︙ | ︙ | |||
219 220 221 222 223 224 225 226 227 228 |
Tcl_ObjCmdProc *\fIobjProc\fR;
void *\fIobjClientData\fR;
Tcl_CmdProc *\fIproc\fR;
void *\fIclientData\fR;
Tcl_CmdDeleteProc *\fIdeleteProc\fR;
void *\fIdeleteData\fR;
Tcl_Namespace *\fInamespacePtr\fR;
} \fBTcl_CmdInfo\fR;
.CE
.PP
| > > | > | | | | > > | 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 |
Tcl_ObjCmdProc *\fIobjProc\fR;
void *\fIobjClientData\fR;
Tcl_CmdProc *\fIproc\fR;
void *\fIclientData\fR;
Tcl_CmdDeleteProc *\fIdeleteProc\fR;
void *\fIdeleteData\fR;
Tcl_Namespace *\fInamespacePtr\fR;
Tcl_ObjCmdProc2 *\fIobjProc2\fR;
void *\fIobjClientData2\fR;
} \fBTcl_CmdInfo\fR;
.CE
.PP
The \fIisNativeObjectProc\fR field has the value 2 if
\fBTcl_CreateObjCommand2\fR was called to register the command;
it has the value 1 if \fBTcl_CreateObjCommand\fR was called to
register the command; it is 0 if only \fBTcl_CreateCommand\fR was called.
It allows a program to determine whether it is faster to
call \fIobjProc2\fR, \fIobjProc\fR or \fIproc\fR:
\fIobjProc2\fR/\fIobjProc\fR is normally faster
if \fIisNativeObjectProc\fR has the value 2;
\fIobjProc\fR/\fIobjProc\fR is normally faster
if \fIisNativeObjectProc\fR has the value 1.
The fields \fIobjProc\fR and \fIobjClientData\fR
have the same meaning as the \fIproc\fR and \fIclientData\fR
arguments to \fBTcl_CreateObjCommand\fR;
they hold information about the value-based command procedure
that the Tcl interpreter calls to implement the command.
The fields \fIproc\fR and \fIclientData\fR
|
| ︙ | ︙ | |||
304 305 306 307 308 309 310 | is appended to the value specified by \fIobjPtr\fR. .PP \fBTcl_GetCommandFromObj\fR returns a token for the command specified by the name in a \fBTcl_Obj\fR. The command name is resolved relative to the current namespace. Returns NULL if the command is not found. .PP | < < < < < < < < < < < < < < < | 319 320 321 322 323 324 325 326 327 328 329 330 331 332 | is appended to the value specified by \fIobjPtr\fR. .PP \fBTcl_GetCommandFromObj\fR returns a token for the command specified by the name in a \fBTcl_Obj\fR. The command name is resolved relative to the current namespace. Returns NULL if the command is not found. .PP .SH "REFERENCE COUNT MANAGEMENT" .PP When the \fIproc\fR passed to \fBTcl_CreateObjCommand\fR is called, the values in its \fIobjv\fR argument will have a reference count of at least 1, with that guaranteed reference being from the Tcl evaluation stack. You should not call \fBTcl_DecrRefCount\fR on any of those values unless you call \fBTcl_IncrRefCount\fR on them first. |
| ︙ | ︙ |
Changes to doc/CrtTrace.3.
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2002 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_CreateTrace 3 "" Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | > > > > > > | | 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 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2002 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_CreateTrace 3 "" Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_CreateTrace, Tcl_CreateObjTrace, Tcl_CreateObjTrace2, Tcl_DeleteTrace \- arrange for command execution to be traced .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Trace \fBTcl_CreateTrace\fR(\fIinterp, level, proc, clientData\fR) .sp Tcl_Trace \fBTcl_CreateObjTrace\fR(\fIinterp, level, flags, objProc, clientData, deleteProc\fR) .sp Tcl_Trace \fBTcl_CreateObjTrace2\fR(\fIinterp, level, flags, objProc2, clientData, deleteProc\fR) .sp \fBTcl_DeleteTrace\fR(\fIinterp, trace\fR) .SH ARGUMENTS .AS Tcl_CmdObjTraceDeleteProc *deleteProc .AP Tcl_Interp *interp in Interpreter containing command to be traced or untraced. .AP int level in Only commands at or below this nesting level will be traced unless 0 is specified. 1 means top-level commands only, 2 means top-level commands or those that are invoked as immediate consequences of executing top-level commands (procedure bodies, bracketed commands, etc.) and so on. A value of 0 means that commands at any level are traced. .AP int flags in Flags governing the trace execution. See below for details. .AP Tcl_CmdObjTraceProc *objProc in Procedure to call for each command that is executed. See below for details of the calling sequence. .AP Tcl_CmdObjTraceProc2 *objProc2 in Procedure to call for each command that is executed. See below for details of the calling sequence. .AP Tcl_CmdTraceProc *proc in Procedure to call for each command that is executed. See below for details on the calling sequence. .AP void *clientData in Arbitrary one-word value to pass to \fIobjProc\fR, \fIobjProc2\fR or \fIproc\fR. .AP Tcl_CmdObjTraceDeleteProc *deleteProc in Procedure to call when the trace is deleted. See below for details of the calling sequence. A NULL pointer is permissible and results in no callback when the trace is deleted. .AP Tcl_Trace trace in Token for trace to be removed (return value from previous call to \fBTcl_CreateTrace\fR). |
| ︙ | ︙ | |||
95 96 97 98 99 100 101 | .PP The \fIobjProc\fR callback is expected to return a standard Tcl status return code. If this code is \fBTCL_OK\fR (the normal case), then the Tcl interpreter will invoke the command. Any other return code is treated as if the command returned that status, and the command is \fInot\fR invoked. .PP | | < < < < | 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 | .PP The \fIobjProc\fR callback is expected to return a standard Tcl status return code. If this code is \fBTCL_OK\fR (the normal case), then the Tcl interpreter will invoke the command. Any other return code is treated as if the command returned that status, and the command is \fInot\fR invoked. .PP The \fIobjProc\fR callback must not modify \fIobjv\fR in any way. .PP Tracing will only occur for commands at nesting level less than or equal to the \fIlevel\fR parameter (i.e. the \fIlevel\fR parameter to \fIobjProc\fR will always be less than or equal to the \fIlevel\fR parameter to \fBTcl_CreateTrace\fR). .PP Tracing has a significant effect on runtime performance because it |
| ︙ | ︙ |
Changes to doc/DetachPids.3.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 | .sp \fBTcl_ReapDetachedProcs\fR() .sp Tcl_Pid \fBTcl_WaitPid\fR(\fIpid, statusPtr, options\fR) .SH ARGUMENTS .AS Tcl_Pid *statusPtr out | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | .sp \fBTcl_ReapDetachedProcs\fR() .sp Tcl_Pid \fBTcl_WaitPid\fR(\fIpid, statusPtr, options\fR) .SH ARGUMENTS .AS Tcl_Pid *statusPtr out .AP size_t numPids in Number of process ids contained in the array pointed to by \fIpidPtr\fR. .AP int *pidPtr in Address of array containing \fInumPids\fR process ids. .AP Tcl_Pid pid in The id of the process (pipe) to wait for. .AP int *statusPtr out The result of waiting on a process (pipe). Either 0 or ECHILD. |
| ︙ | ︙ |
Changes to doc/DictObj.3.
| ︙ | ︙ | |||
66 67 68 69 70 71 72 | dictionary value (or sub-value, in the case of \fBTcl_DictObjPutKeyList\fR.) .AP Tcl_Obj **valuePtrPtr out Points to a variable that will have the value from a key/value pair placed within it. For \fBTcl_DictObjFirst\fR and \fBTcl_DictObjNext\fR, this may be NULL to indicate that the caller is not interested in the value. | | | | 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 91 92 93 94 | dictionary value (or sub-value, in the case of \fBTcl_DictObjPutKeyList\fR.) .AP Tcl_Obj **valuePtrPtr out Points to a variable that will have the value from a key/value pair placed within it. For \fBTcl_DictObjFirst\fR and \fBTcl_DictObjNext\fR, this may be NULL to indicate that the caller is not interested in the value. .AP "size_t \&| int" *sizePtr out Points to a variable that will have the number of key/value pairs contained within the dictionary placed within it. .AP Tcl_DictSearch *searchPtr in/out Pointer to record to use to keep track of progress in enumerating all key/value pairs in a dictionary. The contents of the record will be initialized by the call to \fBTcl_DictObjFirst\fR. If the enumerating is to be terminated before all values in the dictionary have been returned, the search record \fImust\fR be passed to \fBTcl_DictObjDone\fR to enable the internal locks to be released. .AP int *donePtr out Points to a variable that will have a non-zero value written into it when the enumeration of the key/value pairs in a dictionary has completed, and a zero otherwise. .AP size_t keyc in Indicates the number of keys that will be supplied in the \fIkeyv\fR array. .AP "Tcl_Obj *const" *keyv in Array of \fIkeyc\fR pointers to values that \fBTcl_DictObjPutKeyList\fR and \fBTcl_DictObjRemoveKeyList\fR will use to locate the key/value pair to manipulate within the sub-dictionaries of the main dictionary value passed to them. |
| ︙ | ︙ | |||
134 135 136 137 138 139 140 | error if the key did not previously exist. The result of this procedure is \fBTCL_OK\fR, or \fBTCL_ERROR\fR if the \fIdictPtr\fR cannot be converted to a dictionary. .PP \fBTcl_DictObjSize\fR updates the given variable with the number of key/value pairs currently in the given dictionary. The result of this procedure is \fBTCL_OK\fR, or \fBTCL_ERROR\fR if the \fIdictPtr\fR cannot be | | > | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 | error if the key did not previously exist. The result of this procedure is \fBTCL_OK\fR, or \fBTCL_ERROR\fR if the \fIdictPtr\fR cannot be converted to a dictionary. .PP \fBTcl_DictObjSize\fR updates the given variable with the number of key/value pairs currently in the given dictionary. The result of this procedure is \fBTCL_OK\fR, or \fBTCL_ERROR\fR if the \fIdictPtr\fR cannot be converted to a dictionary or if \fIsizePtr\fR points to a variable of type \fBint\fR and the dict contains more than 2**31 key/value pairs. .PP \fBTcl_DictObjFirst\fR commences an iteration across all the key/value pairs in the given dictionary, placing the key and value in the variables pointed to by the \fIkeyPtrPtr\fR and \fIvaluePtrPtr\fR arguments (which may be NULL to indicate that the caller is uninterested in they key or variable respectively.) The next key/value pair in the dictionary may be retrieved with |
| ︙ | ︙ |
Changes to doc/Eval.3.
| ︙ | ︙ | |||
46 47 48 49 50 51 52 | .AP Tcl_Obj *objPtr in A Tcl value containing the script to execute. .AP int flags in ORed combination of flag bits that specify additional options. \fBTCL_EVAL_GLOBAL\fR and \fBTCL_EVAL_DIRECT\fR are currently supported. .AP "const char" *fileName in Name of a file containing a Tcl script. | | | | 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | .AP Tcl_Obj *objPtr in A Tcl value containing the script to execute. .AP int flags in ORed combination of flag bits that specify additional options. \fBTCL_EVAL_GLOBAL\fR and \fBTCL_EVAL_DIRECT\fR are currently supported. .AP "const char" *fileName in Name of a file containing a Tcl script. .AP size_t objc in The number of values in the array pointed to by \fIobjv\fR; this is also the number of words in the command. .AP Tcl_Obj **objv in Points to an array of pointers to values; each value holds the value of a single word in the command to execute. .AP int numBytes in The number of bytes in \fIscript\fR, not including any null terminating character. If \-1, then all characters up to the |
| ︙ | ︙ |
Changes to doc/FileSystem.3.
| ︙ | ︙ | |||
216 217 218 219 220 221 222 | The first of two path values to compare. The value may be converted to \fBpath\fR type. .AP Tcl_Obj *secondPtr in The second of two path values to compare. The value may be converted to \fBpath\fR type. .AP Tcl_Obj *listObj in The list of path elements to operate on with a \fBjoin\fR operation. | | | | | 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 | The first of two path values to compare. The value may be converted to \fBpath\fR type. .AP Tcl_Obj *secondPtr in The second of two path values to compare. The value may be converted to \fBpath\fR type. .AP Tcl_Obj *listObj in The list of path elements to operate on with a \fBjoin\fR operation. .AP size_t elements in The number of elements in the \fIlistObj\fR which should be joined together. If TCL_INDEX_NONE, then all elements are joined. .AP Tcl_Obj **errorPtr out In the case of an error, filled with a value containing the name of the file which caused an error in the various copy/rename operations. .AP int index in The index of the attribute in question. .AP Tcl_Obj *objPtr in The value to set in the operation. |
| ︙ | ︙ | |||
265 266 267 268 269 270 271 | used to set those values for a given file. .AP "const char" *modeString in Specifies how the file is to be accessed. May have any of the values allowed for the \fImode\fR argument to the Tcl \fBopen\fR command. .AP int permissions in POSIX-style permission flags such as 0644. If a new file is created, these permissions will be set on the created file. | | | | 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 | used to set those values for a given file. .AP "const char" *modeString in Specifies how the file is to be accessed. May have any of the values allowed for the \fImode\fR argument to the Tcl \fBopen\fR command. .AP int permissions in POSIX-style permission flags such as 0644. If a new file is created, these permissions will be set on the created file. .AP "size_t \&| int" *lenPtr out If non-NULL, filled with the number of elements in the split path. .AP Tcl_Obj *basePtr in The base path on to which to join the given elements. May be NULL. .AP size_t objc in The number of elements in \fIobjv\fR. .AP "Tcl_Obj *const" objv[] in The elements to join to the given base path. .AP Tcl_Obj *linkNamePtr in The name of the link to be created or read. .AP Tcl_Obj *toPtr in What the link called \fIlinkNamePtr\fR should be linked to, or NULL if |
| ︙ | ︙ |
Changes to doc/GetVersion.3.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | Tcl_GetVersion \- get the version of the library at runtime .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp \fBTcl_GetVersion\fR(\fImajor, minor, patchLevel, type\fR) .SH ARGUMENTS | < | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | Tcl_GetVersion \- get the version of the library at runtime .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp \fBTcl_GetVersion\fR(\fImajor, minor, patchLevel, type\fR) .SH ARGUMENTS .AP int *major out Major version number of the Tcl library. .AP int *minor out Minor version number of the Tcl library. .AP int *patchLevel out The patch level of the Tcl library (or alpha or beta number). .AP int *type out The type of release, also indicates the type of patch level. Can be one of \fBTCL_ALPHA_RELEASE\fR, \fBTCL_BETA_RELEASE\fR, or \fBTCL_FINAL_RELEASE\fR. .BE .SH DESCRIPTION .PP |
| ︙ | ︙ |
Changes to doc/Limit.3.
| ︙ | ︙ | |||
61 62 63 64 65 66 67 | .AS Tcl_LimitHandlerDeleteProc commandLimit in/out .AP Tcl_Interp *interp in Interpreter that the limit being managed applies to or that will have its limits checked. .AP int type in The type of limit that the operation refers to. This must be either \fBTCL_LIMIT_COMMANDS\fR or \fBTCL_LIMIT_TIME\fR. | | | 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 | .AS Tcl_LimitHandlerDeleteProc commandLimit in/out .AP Tcl_Interp *interp in Interpreter that the limit being managed applies to or that will have its limits checked. .AP int type in The type of limit that the operation refers to. This must be either \fBTCL_LIMIT_COMMANDS\fR or \fBTCL_LIMIT_TIME\fR. .AP size_t commandLimit in The maximum number of commands (as reported by \fBinfo cmdcount\fR) that may be executed in the interpreter. .AP Tcl_Time *timeLimitPtr in/out A pointer to a structure that will either have the new time limit read from (\fBTcl_LimitSetTime\fR) or the current time limit written to (\fBTcl_LimitGetTime\fR). .AP int granularity in |
| ︙ | ︙ |
Changes to doc/LinkVar.3.
| ︙ | ︙ | |||
49 50 51 52 53 54 55 | \fBTCL_LINK_BOOLEAN\fR, or one of the extra ones listed below. .sp In \fBTcl_LinkVar\fR, the additional linked type \fBTCL_LINK_STRING\fR may be used. .sp .VS "TIP 312" In \fBTcl_LinkArray\fR, the additional linked types \fBTCL_LINK_CHARS\fR and | | | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | \fBTCL_LINK_BOOLEAN\fR, or one of the extra ones listed below. .sp In \fBTcl_LinkVar\fR, the additional linked type \fBTCL_LINK_STRING\fR may be used. .sp .VS "TIP 312" In \fBTcl_LinkArray\fR, the additional linked types \fBTCL_LINK_CHARS\fR and \fBTCL_LINK_BINARY\fR may be used. .VE "TIP 312" .sp All the above for both functions may be optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR to make the Tcl variable read-only. .AP size_t size in .VS "TIP 312" |
| ︙ | ︙ | |||
142 143 144 145 146 147 148 | write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/decimal/binary prefix) are accepted as if they are valid too. .RS .PP .VS "TIP 312" | | | | 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 | write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/decimal/binary prefix) are accepted as if they are valid too. .RS .PP .VS "TIP 312" If using an array of these, consider using \fBTCL_LINK_BINARY\fR instead. .VE "TIP 312" .RE .TP \fBTCL_LINK_BINARY\fR .VS "TIP 312" The C array is of type \fBunsigned char *\fR and is mapped into Tcl as a bytearray. Any value written into the Tcl variable must have the same length as the underlying storage. Only supported with \fBTcl_LinkArray\fR. .VE "TIP 312" .TP |
| ︙ | ︙ |
Changes to doc/ListObj.3.
| ︙ | ︙ | |||
55 56 57 58 59 60 61 | an attempt will be made to convert it to one. .AP Tcl_Obj *objPtr in For \fBTcl_ListObjAppendElement\fR, points to the Tcl value that will be appended to \fIlistPtr\fR. For \fBTcl_SetListObj\fR, this points to the Tcl value that will be converted to a list value containing the \fIobjc\fR elements of the array referenced by \fIobjv\fR. | | | | | | | | 55 56 57 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 91 92 93 94 95 96 97 98 99 100 | an attempt will be made to convert it to one. .AP Tcl_Obj *objPtr in For \fBTcl_ListObjAppendElement\fR, points to the Tcl value that will be appended to \fIlistPtr\fR. For \fBTcl_SetListObj\fR, this points to the Tcl value that will be converted to a list value containing the \fIobjc\fR elements of the array referenced by \fIobjv\fR. .AP "size_t \&| int" *objcPtr in Points to location where \fBTcl_ListObjGetElements\fR stores the number of element values in \fIlistPtr\fR. .AP Tcl_Obj ***objvPtr out A location where \fBTcl_ListObjGetElements\fR stores a pointer to an array of pointers to the element values of \fIlistPtr\fR. .AP size_t objc in The number of Tcl values that \fBTcl_NewListObj\fR will insert into a new list value, and \fBTcl_ListObjReplace\fR will insert into \fIlistPtr\fR. For \fBTcl_SetListObj\fR, the number of Tcl values to insert into \fIobjPtr\fR. .AP "Tcl_Obj *const" objv[] in An array of pointers to values. \fBTcl_NewListObj\fR will insert these values into a new list value and \fBTcl_ListObjReplace\fR will insert them into an existing \fIlistPtr\fR. Each value will become a separate list element. .AP "size_t \&| int" *lengthPtr out Points to location where \fBTcl_ListObjLength\fR stores the length of the list. .AP size_t index in Index of the list element that \fBTcl_ListObjIndex\fR is to return. The first element has index 0. .AP Tcl_Obj **objPtrPtr out Points to place where \fBTcl_ListObjIndex\fR is to store a pointer to the resulting list element value. .AP size_t first in Index of the starting list element that \fBTcl_ListObjReplace\fR is to replace. The list's first element has index 0. .AP size_t count in The number of elements that \fBTcl_ListObjReplace\fR is to replace. .BE .SH DESCRIPTION .PP Tcl list values have an internal representation that supports |
| ︙ | ︙ | |||
149 150 151 152 153 154 155 | .PP \fBTcl_ListObjGetElements\fR returns a count and a pointer to an array of the elements in a list value. It returns the count by storing it in the address \fIobjcPtr\fR. Similarly, it returns the array pointer by storing it in the address \fIobjvPtr\fR. The memory pointed to is managed by Tcl and should not be freed or written to by the caller. If the list is empty, 0 is stored at \fIobjcPtr\fR | | > > | > > | | | | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 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 219 | .PP \fBTcl_ListObjGetElements\fR returns a count and a pointer to an array of the elements in a list value. It returns the count by storing it in the address \fIobjcPtr\fR. Similarly, it returns the array pointer by storing it in the address \fIobjvPtr\fR. The memory pointed to is managed by Tcl and should not be freed or written to by the caller. If the list is empty, 0 is stored at \fIobjcPtr\fR and NULL at \fIobjvPtr\fR. If \fIobjcPtr\fR points to a variable of type \fBint\fR and the list contains more than 2**31 elements, the function returns \fBTCL_ERROR\fR. If \fIlistPtr\fR is not already a list value, \fBTcl_ListObjGetElements\fR will attempt to convert it to one; if the conversion fails, it returns \fBTCL_ERROR\fR and leaves an error message in the interpreter's result value if \fIinterp\fR is not NULL. Otherwise it returns \fBTCL_OK\fR after storing the count and array pointer. .PP \fBTcl_ListObjLength\fR returns the number of elements in the list value referenced by \fIlistPtr\fR. It returns this count by storing a value in the address \fIlengthPtr\fR. If \fIlengthPtr\fR points to a variable of type \fBint\fR and the list contains more than 2**31 elements, the function returns \fBTCL_ERROR\fR. If the value is not already a list value, \fBTcl_ListObjLength\fR will attempt to convert it to one; if the conversion fails, it returns \fBTCL_ERROR\fR and leaves an error message in the interpreter's result value if \fIinterp\fR is not NULL. Otherwise it returns \fBTCL_OK\fR after storing the list's length. .PP The procedure \fBTcl_ListObjIndex\fR returns a pointer to the value at element \fIindex\fR in the list referenced by \fIlistPtr\fR. It returns this value by storing a pointer to it in the address \fIobjPtrPtr\fR. If \fIlistPtr\fR does not already refer to a list value, \fBTcl_ListObjIndex\fR will attempt to convert it to one; if the conversion fails, it returns \fBTCL_ERROR\fR and leaves an error message in the interpreter's result value if \fIinterp\fR is not NULL. If the index is out of range, that is, \fIindex\fR is TCL_INDEX_NONE or greater than or equal to the number of elements in the list, \fBTcl_ListObjIndex\fR stores a NULL in \fIobjPtrPtr\fR and returns \fBTCL_OK\fR. Otherwise it returns \fBTCL_OK\fR after storing the element's value pointer. The reference count for the list element is not incremented; the caller must do that if it needs to retain a pointer to the element. .PP \fBTcl_ListObjReplace\fR replaces zero or more elements of the list referenced by \fIlistPtr\fR with the \fIobjc\fR values in the array referenced by \fIobjv\fR. If \fIlistPtr\fR does not point to a list value, \fBTcl_ListObjReplace\fR will attempt to convert it to one; if the conversion fails, it returns \fBTCL_ERROR\fR and leaves an error message in the interpreter's result value if \fIinterp\fR is not NULL. Otherwise, it returns \fBTCL_OK\fR after replacing the values. If \fIobjv\fR is NULL, no new elements are added. If the argument \fIfirst\fR is zero or TCL_INDEX_NONE, it refers to the first element. If \fIfirst\fR is greater than or equal to the number of elements in the list, then no elements are deleted; the new elements are appended to the list. \fIcount\fR gives the number of elements to replace. If \fIcount\fR is zero or TCL_INDEX_NONE then no elements are deleted; the new elements are simply inserted before the one designated by \fIfirst\fR. \fBTcl_ListObjReplace\fR invalidates \fIlistPtr\fR's old string representation. The reference counts of any elements inserted from \fIobjv\fR are incremented since the resulting list now refers to them. Similarly, the reference counts for any replaced values are decremented. |
| ︙ | ︙ |
Changes to doc/Method.3.
| ︙ | ︙ | |||
54 55 56 57 58 59 60 | .sp Tcl_Method \fBTcl_ObjectContextMethod\fR(\fIcontext\fR) .sp Tcl_Object \fBTcl_ObjectContextObject\fR(\fIcontext\fR) .sp | | | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | .sp Tcl_Method \fBTcl_ObjectContextMethod\fR(\fIcontext\fR) .sp Tcl_Object \fBTcl_ObjectContextObject\fR(\fIcontext\fR) .sp size_t \fBTcl_ObjectContextSkippedArgs\fR(\fIcontext\fR) .SH ARGUMENTS .AS void *clientData in .AP Tcl_Interp *interp in/out The interpreter holding the object or class to create or update a method in. .AP Tcl_Object object in The object to create the method in. |
| ︙ | ︙ | |||
91 92 93 94 95 96 97 | when the method was created. If NULL, the \fIclientData\fR value will not be retrieved. .AP Tcl_Method method in A reference to a method to query. .AP Tcl_ObjectContext context in A reference to a method-call context. Note that client code \fImust not\fR retain a reference to a context. | | | | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 | when the method was created. If NULL, the \fIclientData\fR value will not be retrieved. .AP Tcl_Method method in A reference to a method to query. .AP Tcl_ObjectContext context in A reference to a method-call context. Note that client code \fImust not\fR retain a reference to a context. .AP size_t objc in The number of arguments to pass to the method implementation. .AP "Tcl_Obj *const" *objv in An array of arguments to pass to the method implementation. .AP size_t skip in The number of arguments passed to the method implementation that do not represent "real" arguments. .BE .SH DESCRIPTION .PP A method is an operation carried out on an object that is associated with the object. Every method must be attached to either an object or a class; methods |
| ︙ | ︙ |
Changes to doc/NRE.3.
1 2 3 4 5 6 7 8 9 10 11 | .\" .\" Copyright (c) 2008 Kevin B. Kenny. .\" Copyright (c) 2018 Nathan Coulter. .\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH NRE 3 8.6 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | > > > > > > > | 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 |
.\"
.\" Copyright (c) 2008 Kevin B. Kenny.
.\" Copyright (c) 2018 Nathan Coulter.
.\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH NRE 3 8.6 Tcl "Tcl Library Procedures"
.so man.macros
.BS
.SH NAME
Tcl_NRCreateCommand, Tcl_NRCreateCommand2, Tcl_NRCallObjProc, Tcl_NRCallObjProc2, 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)
.sp
Tcl_Command
\fBTcl_NRCreateCommand2\fR(\fIinterp, cmdName, proc2, nreProc2, clientData,
deleteProc\fR)
.sp
int
\fBTcl_NRCallObjProc\fR(\fIinterp, nreProc, clientData, objc, objv\fR)
.sp
int
\fBTcl_NRCallObjProc2\fR(\fIinterp, nreProc2, clientData, objc, objv\fR)
.sp
int
\fBTcl_NREvalObj\fR(\fIinterp, objPtr, flags\fR)
.sp
int
\fBTcl_NREvalObjv\fR(\fIinterp, objc, objv, flags\fR)
.sp
int
|
| ︙ | ︙ | |||
43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | .AP "const char" *cmdName in Name of the command to create. .AP Tcl_ObjCmdProc *proc in Called in order to evaluate a command. Is often just a small wrapper that uses \fBTcl_NRCallObjProc\fR to call \fInreProc\fR using a new trampoline. Behaves in the same way as the \fIproc\fR argument to \fBTcl_CreateObjCommand\fR(3) (\fIq.v.\fR). .AP Tcl_ObjCmdProc *nreProc in Called instead of \fIproc\fR when a trampoline is already in use. .AP void *clientData in Arbitrary one-word value passed to \fIproc\fR, \fInreProc\fR, \fIdeleteProc\fR and \fIobjProc\fR. .AP Tcl_CmdDeleteProc *deleteProc in/out Called before \fIcmdName\fR is deleted from the interpreter, allowing for command-specific cleanup. May be NULL. | > > > > > > > | | 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | .AP "const char" *cmdName in Name of the command to create. .AP Tcl_ObjCmdProc *proc in Called in order to evaluate a command. Is often just a small wrapper that uses \fBTcl_NRCallObjProc\fR to call \fInreProc\fR using a new trampoline. Behaves in the same way as the \fIproc\fR argument to \fBTcl_CreateObjCommand\fR(3) (\fIq.v.\fR). .AP Tcl_ObjCmdProc2 *proc2 in Called in order to evaluate a command. Is often just a small wrapper that uses \fBTcl_NRCallObjProc2\fR to call \fInreProc2\fR using a new trampoline. Behaves in the same way as the \fIproc2\fR argument to \fBTcl_CreateObjCommand2\fR(3) (\fIq.v.\fR). .AP Tcl_ObjCmdProc *nreProc in Called instead of \fIproc\fR when a trampoline is already in use. .AP Tcl_ObjCmdProc2 *nreProc2 in Called instead of \fIproc2\fR when a trampoline is already in use. .AP void *clientData in Arbitrary one-word value passed to \fIproc\fR, \fInreProc\fR, \fIdeleteProc\fR and \fIobjProc\fR. .AP Tcl_CmdDeleteProc *deleteProc in/out Called before \fIcmdName\fR is deleted from the interpreter, allowing for command-specific cleanup. May be NULL. .AP size_t objc in Number of items in \fIobjv\fR. .AP Tcl_Obj **objv in Words in the command. .AP Tcl_Obj *objPtr in A script or expression to evaluate. .AP int flags in As described for \fITcl_EvalObjv\fR. |
| ︙ | ︙ | |||
99 100 101 102 103 104 105 106 107 108 109 110 111 112 | resolves \fIcmdName\fR, which may contain namespace qualifiers, relative to the current namespace, creates a command by that name, and returns a token for the command which may be used in subsequent calls to \fBTcl_GetCommandName\fR. Except for a few cases noted below any existing command by the same name is first deleted. If \fIinterp\fR is in the process of being deleted \fBTcl_NRCreateCommand\fR does not create any command, does not delete any command, and returns NULL. .PP \fBTcl_NREvalObj\fR pushes a function that is like \fBTcl_EvalObjEx\fR but consumes no space on the C stack. .PP \fBTcl_NREvalObjv\fR pushes a function that is like \fBTcl_EvalObjv\fR but consumes no space on the C stack. .PP | > > > | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | resolves \fIcmdName\fR, which may contain namespace qualifiers, relative to the current namespace, creates a command by that name, and returns a token for the command which may be used in subsequent calls to \fBTcl_GetCommandName\fR. Except for a few cases noted below any existing command by the same name is first deleted. If \fIinterp\fR is in the process of being deleted \fBTcl_NRCreateCommand\fR does not create any command, does not delete any command, and returns NULL. .PP \fBTcl_NRCreateCommand2\fR, is an alternative to \fBTcl_NRCreateCommand\fR in the same way as \fBTcl_CreateObjCommand2\fR. .PP \fBTcl_NREvalObj\fR pushes a function that is like \fBTcl_EvalObjEx\fR but consumes no space on the C stack. .PP \fBTcl_NREvalObjv\fR pushes a function that is like \fBTcl_EvalObjv\fR but consumes no space on the C stack. .PP |
| ︙ | ︙ |
Changes to doc/Notifier.3.
| ︙ | ︙ | |||
86 87 88 89 90 91 92 | is specified as an interval (how long to wait), not an absolute time (when to wakeup). If the pointer passed to \fBTcl_WaitForEvent\fR is NULL, it means there is no maximum wait time: wait forever if necessary. .AP Tcl_Event *evPtr in An event to add to the event queue. The storage for the event must have been allocated by the caller using \fBTcl_Alloc\fR. | | | > | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 | is specified as an interval (how long to wait), not an absolute time (when to wakeup). If the pointer passed to \fBTcl_WaitForEvent\fR is NULL, it means there is no maximum wait time: wait forever if necessary. .AP Tcl_Event *evPtr in An event to add to the event queue. The storage for the event must have been allocated by the caller using \fBTcl_Alloc\fR. .AP int position in Where to add the new event in the queue: \fBTCL_QUEUE_TAIL\fR, \fBTCL_QUEUE_HEAD\fR, \fBTCL_QUEUE_MARK\fR, and whether to do an alert if the queue is empty: \fBTCL_QUEUE_ALERT_IF_EMPTY\fR. .AP Tcl_ThreadId threadId in A unique identifier for a thread. .AP Tcl_EventDeleteProc *deleteProc in Procedure to invoke for each queued event in \fBTcl_DeleteEvents\fR. .AP int flags in What types of events to service. These flags are the same as those passed to \fBTcl_DoOneEvent\fR. |
| ︙ | ︙ | |||
336 337 338 339 340 341 342 | The event source must fill in the \fIproc\fR field of the event before calling \fBTcl_QueueEvent\fR. The \fInextPtr\fR is used to link together the events in the queue and should not be modified by the event source. .PP An event may be added to the queue at any of three positions, depending on the \fIposition\fR argument to \fBTcl_QueueEvent\fR: | | | | > > > > | 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 364 365 366 367 368 369 | The event source must fill in the \fIproc\fR field of the event before calling \fBTcl_QueueEvent\fR. The \fInextPtr\fR is used to link together the events in the queue and should not be modified by the event source. .PP An event may be added to the queue at any of three positions, depending on the \fIposition\fR argument to \fBTcl_QueueEvent\fR: .IP \fBTCL_QUEUE_TAIL\fR 32 Add the event at the back of the queue, so that all other pending events will be serviced first. This is almost always the right place for new events. .IP \fBTCL_QUEUE_HEAD\fR 32 Add the event at the front of the queue, so that it will be serviced before all other queued events. .IP \fBTCL_QUEUE_MARK\fR 32 Add the event at the front of the queue, unless there are other events at the front whose position is \fBTCL_QUEUE_MARK\fR; if so, add the new event just after all other \fBTCL_QUEUE_MARK\fR events. This value of \fIposition\fR is used to insert an ordered sequence of events at the front of the queue, such as a series of Enter and Leave events synthesized during a grab or ungrab operation in Tk. .IP \fBTCL_QUEUE_ALERT_IF_EMPTY\fR 32 When used in \fBTcl_ThreadQueueEvent\fR arranges for an automatic call of \fBTcl_ThreadAlert\fR when the queue was empty. .PP When it is time to handle an event from the queue (steps 1 and 4 above) \fBTcl_ServiceEvent\fR will invoke the \fIproc\fR specified in the first queued \fBTcl_Event\fR structure. \fIProc\fR must match the following prototype: .PP .CS |
| ︙ | ︙ |
Changes to doc/OpenFileChnl.3.
| ︙ | ︙ | |||
115 116 117 118 119 120 121 | The name of a local or network file. .AP "const char" *mode in Specifies how the file is to be accessed. May have any of the values allowed for the \fImode\fR argument to the Tcl \fBopen\fR command. .AP int permissions in POSIX-style permission flags such as 0644. If a new file is created, these permissions will be set on the created file. | | | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | The name of a local or network file. .AP "const char" *mode in Specifies how the file is to be accessed. May have any of the values allowed for the \fImode\fR argument to the Tcl \fBopen\fR command. .AP int permissions in POSIX-style permission flags such as 0644. If a new file is created, these permissions will be set on the created file. .AP size_t argc in The number of elements in \fIargv\fR. .AP "const char" **argv in Arguments for constructing a command pipeline. These values have the same meaning as the non-switch arguments to the Tcl \fBexec\fR command. .AP int flags in Specifies the disposition of the stdio handles in pipeline: OR-ed combination of \fBTCL_STDIN\fR, \fBTCL_STDOUT\fR, \fBTCL_STDERR\fR, and |
| ︙ | ︙ |
Changes to doc/ParseArgs.3.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 | \fBTcl_ParseArgsObjv\fR(\fIinterp, argTable, objcPtr, objv, remObjv\fR) .SH ARGUMENTS .AS "const Tcl_ArgvInfo" ***remObjv in/out .AP Tcl_Interp *interp out Where to store error messages. .AP "const Tcl_ArgvInfo" *argTable in Pointer to array of option descriptors. | | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | \fBTcl_ParseArgsObjv\fR(\fIinterp, argTable, objcPtr, objv, remObjv\fR) .SH ARGUMENTS .AS "const Tcl_ArgvInfo" ***remObjv in/out .AP Tcl_Interp *interp out Where to store error messages. .AP "const Tcl_ArgvInfo" *argTable in Pointer to array of option descriptors. .AP "size_t \&| int" *objcPtr in/out A pointer to variable holding number of arguments in \fIobjv\fR. Will be modified to hold number of arguments left in the unprocessed argument list stored in \fIremObjv\fR. .AP "Tcl_Obj *const" *objv in The array of arguments to be parsed. .AP Tcl_Obj ***remObjv out Pointer to a variable that will hold the array of unprocessed arguments. |
| ︙ | ︙ |
Changes to doc/ParseCmd.3.
| ︙ | ︙ | |||
41 42 43 44 45 46 47 | For procedures other than \fBTcl_FreeParse\fR and \fBTcl_EvalTokensStandard\fR, used only for error reporting; if NULL, then no error messages are left after errors. For \fBTcl_EvalTokensStandard\fR, determines the context for evaluating the script and also is used for error reporting; must not be NULL. .AP "const char" *start in Pointer to first character in string to parse. | | | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | For procedures other than \fBTcl_FreeParse\fR and \fBTcl_EvalTokensStandard\fR, used only for error reporting; if NULL, then no error messages are left after errors. For \fBTcl_EvalTokensStandard\fR, determines the context for evaluating the script and also is used for error reporting; must not be NULL. .AP "const char" *start in Pointer to first character in string to parse. .AP size_t numBytes in Number of bytes in string to parse, not including any terminating null character. If less than 0 then the script consists of all characters following \fIstart\fR up to the first null character. .AP int nested in Non-zero means that the script is part of a command substitution so an unquoted close bracket should be treated as a command terminator. If zero, close brackets have no special meaning. |
| ︙ | ︙ | |||
192 193 194 195 196 197 198 |
\fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR,
\fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR
return parse information in two data structures, Tcl_Parse and Tcl_Token:
.PP
.CS
typedef struct Tcl_Parse {
const char *\fIcommentStart\fR;
| | | | | | 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 |
\fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR,
\fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR
return parse information in two data structures, Tcl_Parse and Tcl_Token:
.PP
.CS
typedef struct Tcl_Parse {
const char *\fIcommentStart\fR;
size_t \fIcommentSize\fR;
const char *\fIcommandStart\fR;
size_t \fIcommandSize\fR;
size_t \fInumWords\fR;
Tcl_Token *\fItokenPtr\fR;
size_t \fInumTokens\fR;
...
} \fBTcl_Parse\fR;
typedef struct Tcl_Token {
int \fItype\fR;
const char *\fIstart\fR;
size_t \fIsize\fR;
|
| ︙ | ︙ |
Changes to doc/PkgRequire.3.
| ︙ | ︙ | |||
51 52 53 54 55 56 57 | .AP "const void" *clientData in Arbitrary value to be associated with the package. .AP void *clientDataPtr out Pointer to place to store the value associated with the matching package. It is only changed if the pointer is not NULL and the function completed successfully. The storage can be any pointer type with the same size as a void pointer. | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | .AP "const void" *clientData in Arbitrary value to be associated with the package. .AP void *clientDataPtr out Pointer to place to store the value associated with the matching package. It is only changed if the pointer is not NULL and the function completed successfully. The storage can be any pointer type with the same size as a void pointer. .AP size_t objc in Number of requirements. .AP Tcl_Obj* objv[] in Array of requirements. .BE .SH DESCRIPTION .PP These procedures provide C-level interfaces to Tcl's package and |
| ︙ | ︙ |
Changes to doc/SetRecLmt.3.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | .BS .SH NAME Tcl_SetRecursionLimit \- set maximum allowable nesting depth in interpreter .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp | | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | .BS .SH NAME Tcl_SetRecursionLimit \- set maximum allowable nesting depth in interpreter .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp size_t \fBTcl_SetRecursionLimit\fR(\fIinterp, depth\fR) .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in Interpreter whose recursion limit is to be set. Must be greater than zero. .AP size_t depth in New limit for nested calls to \fBTcl_Eval\fR for \fIinterp\fR. .BE .SH DESCRIPTION .PP At any given time Tcl enforces a limit on the number of recursive calls that may be active for \fBTcl_Eval\fR and related procedures |
| ︙ | ︙ |
Changes to doc/SplitList.3.
| ︙ | ︙ | |||
34 35 36 37 38 39 40 | .SH ARGUMENTS .AS "const char *const" ***argvPtr out .AP Tcl_Interp *interp out Interpreter to use for error reporting. If NULL, then no error message is left. .AP "const char" *list in Pointer to a string with proper list structure. | | | | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | .SH ARGUMENTS .AS "const char *const" ***argvPtr out .AP Tcl_Interp *interp out Interpreter to use for error reporting. If NULL, then no error message is left. .AP "const char" *list in Pointer to a string with proper list structure. .AP "size_t \&| int" *argcPtr out Filled in with number of elements in \fIlist\fR. .AP "const char" ***argvPtr out \fI*argvPtr\fR will be filled in with the address of an array of pointers to the strings that are the extracted elements of \fIlist\fR. There will be \fI*argcPtr\fR valid entries in the array, followed by a NULL entry. .AP size_t argc in Number of elements in \fIargv\fR. .AP "const char *const" *argv in Array of strings to merge together into a single list. Each string will become a separate element of the list. .AP "const char" *src in String that is to become an element of a list. .AP int *flagsPtr in |
| ︙ | ︙ | |||
77 78 79 80 81 82 83 | addition to the array of pointers, it also holds copies of all the list elements. It is the caller's responsibility to free up all of this storage. For example, suppose that you have called \fBTcl_SplitList\fR with the following code: .PP .CS | > | | | > | | 77 78 79 80 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 106 107 108 109 | addition to the array of pointers, it also holds copies of all the list elements. It is the caller's responsibility to free up all of this storage. For example, suppose that you have called \fBTcl_SplitList\fR with the following code: .PP .CS size_t argc; int code; char *string; char **argv; \&... code = \fBTcl_SplitList\fR(interp, string, &argc, &argv); .CE .PP Then you should eventually free the storage with a call like the following: .PP .CS Tcl_Free(argv); .CE .PP \fBTcl_SplitList\fR normally returns \fBTCL_OK\fR, which means the list was successfully parsed. If \fIsizePtr\fR points to a variable of type \fBint\fR and the list contains more than 2**31 key/value pairs, or there was a syntax error in \fIlist\fR, then \fBTCL_ERROR\fR is returned and the interpreter's result will point to an error message describing the problem (if \fIinterp\fR was not NULL). If \fBTCL_ERROR\fR is returned then no memory is allocated and \fI*argvPtr\fR is not modified. .PP \fBTcl_Merge\fR is the inverse of \fBTcl_SplitList\fR: it takes a collection of strings given by \fIargc\fR |
| ︙ | ︙ |
Changes to doc/SplitPath.3.
| ︙ | ︙ | |||
21 22 23 24 25 26 27 | Tcl_PathType \fBTcl_GetPathType\fR(\fIpath\fR) .SH ARGUMENTS .AS "const char *const" ***argvPtr in/out .AP "const char" *path in File path in a form appropriate for the current platform (see the \fBfilename\fR manual entry for acceptable forms for path names). | | | | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | Tcl_PathType \fBTcl_GetPathType\fR(\fIpath\fR) .SH ARGUMENTS .AS "const char *const" ***argvPtr in/out .AP "const char" *path in File path in a form appropriate for the current platform (see the \fBfilename\fR manual entry for acceptable forms for path names). .AP "size_t \&| int" *argcPtr out Filled in with number of path elements in \fIpath\fR. .AP "const char" ***argvPtr out \fI*argvPtr\fR will be filled in with the address of an array of pointers to the strings that are the extracted elements of \fIpath\fR. There will be \fI*argcPtr\fR valid entries in the array, followed by a NULL entry. .AP size_t argc in Number of elements in \fIargv\fR. .AP "const char *const" *argv in Array of path elements to merge together into a single path. .AP Tcl_DString *resultPtr in/out A pointer to an initialized \fBTcl_DString\fR to which the result of \fBTcl_JoinPath\fR will be appended. .BE |
| ︙ | ︙ | |||
57 58 59 60 61 62 63 | dynamically allocated; in addition to the array of pointers, it also holds copies of all the path elements. It is the caller's responsibility to free all of this storage. For example, suppose that you have called \fBTcl_SplitPath\fR with the following code: .PP .CS | | | | 57 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 | dynamically allocated; in addition to the array of pointers, it also holds copies of all the path elements. It is the caller's responsibility to free all of this storage. For example, suppose that you have called \fBTcl_SplitPath\fR with the following code: .PP .CS size_t argc; char *path; char **argv; \&... Tcl_SplitPath(string, &argc, &argv); .CE .PP Then you should eventually free the storage with a call like the following: .PP .CS Tcl_Free(argv); .CE .PP \fBTcl_JoinPath\fR is the inverse of \fBTcl_SplitPath\fR: it takes a collection of path elements given by \fIargc\fR and \fIargv\fR and generates a result string that is a properly constructed path. The result string is appended to \fIresultPtr\fR. \fIResultPtr\fR must refer to an initialized \fBTcl_DString\fR. |
| ︙ | ︙ |
Changes to doc/StringObj.3.
| ︙ | ︙ | |||
114 115 116 117 118 119 120 | The index of the last Unicode character in the Unicode range to be returned as a new value. If \fBTCL_INDEX_NONE\fR, take all characters up to the last one available. .AP Tcl_Obj *objPtr in/out Points to a value to manipulate. .AP Tcl_Obj *appendObjPtr in The value to append to \fIobjPtr\fR in \fBTcl_AppendObjToObj\fR. | | | | 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 | The index of the last Unicode character in the Unicode range to be returned as a new value. If \fBTCL_INDEX_NONE\fR, take all characters up to the last one available. .AP Tcl_Obj *objPtr in/out Points to a value to manipulate. .AP Tcl_Obj *appendObjPtr in The value to append to \fIobjPtr\fR in \fBTcl_AppendObjToObj\fR. .AP "size_t \&| int" *lengthPtr out The location where \fBTcl_GetStringFromObj\fR will store the length of a value's string representation. May be (int *)NULL when not used. .AP "const char" *string in Null-terminated string value to append to \fIobjPtr\fR. .AP va_list argList in An argument list which must have been initialized using \fBva_start\fR, and cleared using \fBva_end\fR. .AP size_t limit in Maximum number of bytes to be appended. .AP "const char" *ellipsis in Suffix to append when the limit leads to string truncation. If NULL is passed then the suffix .QW "..." is used. .AP "const char" *format in Format control string including % conversion specifiers. .AP size_t objc in The number of elements to format or concatenate. .AP Tcl_Obj *objv[] in The array of values to format or concatenate. .AP size_t newLength in New length for the string value of \fIobjPtr\fR, not including the final null character. .BE |
| ︙ | ︙ | |||
184 185 186 187 188 189 190 | limited purpose, the pointer returned by \fBTcl_GetStringFromObj\fR or \fBTcl_GetString\fR should be treated as read-only. It is recommended that this pointer be assigned to a (const char *) variable. Even in the limited situations where writing to this pointer is acceptable, one should take care to respect the copy-on-write semantics required by \fBTcl_Obj\fR's, with appropriate calls to \fBTcl_IsShared\fR and \fBTcl_DuplicateObj\fR prior to any | | > > | > | 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 | limited purpose, the pointer returned by \fBTcl_GetStringFromObj\fR or \fBTcl_GetString\fR should be treated as read-only. It is recommended that this pointer be assigned to a (const char *) variable. Even in the limited situations where writing to this pointer is acceptable, one should take care to respect the copy-on-write semantics required by \fBTcl_Obj\fR's, with appropriate calls to \fBTcl_IsShared\fR and \fBTcl_DuplicateObj\fR prior to any in-place modification of the string representation. If \fIlengthPtr\fR points to an \fBint\fR variable, and the string has more than 2^31 bytes, a panic will result. The procedure \fBTcl_GetString\fR is used in the common case where the caller does not need the length of the string representation. .PP \fBTcl_GetUnicodeFromObj\fR and \fBTcl_GetUnicode\fR return a value's value as a Unicode string. This is given by the returned pointer and (for \fBTcl_GetUnicodeFromObj\fR) length, which is stored in \fIlengthPtr\fR if it is non-NULL. The storage referenced by the returned byte pointer is owned by the value manager and should not be modified by the caller. The procedure \fBTcl_GetUnicode\fR is used in the common case where the caller does not need the length of the unicode string representation. If \fIlengthPtr\fR points to an \fBint\fR variable, and the string has more than 2^31 unicode characters, a panic will result. .PP \fBTcl_GetUniChar\fR returns the \fIindex\fR'th character in the value's Unicode representation. If the index is out of range or it references a low surrogate preceded by a high surrogate, it returns -1; .PP \fBTcl_GetRange\fR returns a newly created value comprised of the characters between \fIfirst\fR and \fIlast\fR (inclusive) in the |
| ︙ | ︙ |
Changes to doc/Tcl_Main.3.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | .sp Tcl_Obj * \fBTcl_GetStartupScript\fR(\fIencodingPtr\fR) .sp \fBTcl_SetMainLoop\fR(\fImainLoopProc\fR) .SH ARGUMENTS .AS Tcl_MainLoopProc *mainLoopProc | | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | .sp Tcl_Obj * \fBTcl_GetStartupScript\fR(\fIencodingPtr\fR) .sp \fBTcl_SetMainLoop\fR(\fImainLoopProc\fR) .SH ARGUMENTS .AS Tcl_MainLoopProc *mainLoopProc .AP size_t argc in Number of elements in \fIargv\fR. .AP char *argv[] in Array of strings containing command-line arguments. On Windows, when using -DUNICODE, the parameter type changes to wchar_t *. .AP char *charargv[] in As argv, but does not change type to wchar_t. .AP char *wideargv[] in |
| ︙ | ︙ | |||
81 82 83 84 85 86 87 | Normally each shell application contains a small \fBmain\fR function that does nothing but invoke \fBTcl_Main\fR. \fBTcl_Main\fR then does all the work of creating and running a \fBtclsh\fR-like application. .PP \fBTcl_Main\fR is not provided by the public interface of Tcl's stub library. Programs that call \fBTcl_Main\fR must be linked | | > > | | 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 | Normally each shell application contains a small \fBmain\fR function that does nothing but invoke \fBTcl_Main\fR. \fBTcl_Main\fR then does all the work of creating and running a \fBtclsh\fR-like application. .PP \fBTcl_Main\fR is not provided by the public interface of Tcl's stub library. Programs that call \fBTcl_Main\fR must be linked against the standard Tcl library. If the standard Tcl library is a dll (so, not a static .lib/.a) , then the program must be linked against the stub library as well. Extensions (stub-enabled or not) are not intended to call \fBTcl_Main\fR. .PP \fBTcl_Main\fR is not thread-safe. It should only be called by a single main thread of a multi-threaded application. This restriction is not a problem with normal use described above. .PP \fBTcl_Main\fR and therefore all applications based upon it, like \fBtclsh\fR, use \fBTcl_GetStdChannel\fR to initialize the standard |
| ︙ | ︙ |
Changes to doc/TraceVar.3.
| ︙ | ︙ | |||
122 123 124 125 126 127 128 |
It should have arguments and result that match the type
\fBTcl_VarTraceProc\fR:
.PP
.CS
typedef char *\fBTcl_VarTraceProc\fR(
void *\fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
| | | | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 |
It should have arguments and result that match the type
\fBTcl_VarTraceProc\fR:
.PP
.CS
typedef char *\fBTcl_VarTraceProc\fR(
void *\fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
const char *\fIname1\fR,
const char *\fIname2\fR,
int \fIflags\fR);
.CE
.PP
The \fIclientData\fR and \fIinterp\fR parameters will
have the same values as those passed to \fBTcl_TraceVar\fR when the
trace was created.
\fIclientData\fR typically points to an application-specific
|
| ︙ | ︙ |
Changes to doc/Translate.3.
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_TranslateFileName 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_TranslateFileName 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_TranslateFileName \- convert file name to native form .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp char * \fBTcl_TranslateFileName\fR(\fIinterp\fR, \fIname\fR, \fIbufferPtr\fR) .SH ARGUMENTS |
| ︙ | ︙ | |||
30 31 32 33 34 35 36 | anything stored here. .BE .SH DESCRIPTION .PP This utility procedure translates a file name to a platform-specific form which, after being converted to the appropriate encoding, is suitable for passing to the local operating system. In particular, it converts | | | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | anything stored here. .BE .SH DESCRIPTION .PP This utility procedure translates a file name to a platform-specific form which, after being converted to the appropriate encoding, is suitable for passing to the local operating system. In particular, it converts network names into native form. .PP However, with the advent of the newer \fBTcl_FSGetNormalizedPath\fR and \fBTcl_FSGetNativePath\fR, there is no longer any need to use this procedure. In particular, \fBTcl_FSGetNativePath\fR performs all the necessary translation and encoding conversion, is virtual-filesystem aware, and caches the native result for faster repeated calls. Finally \fBTcl_FSGetNativePath\fR does not require you to free anything afterwards. .PP If \fBTcl_TranslateFileName\fR has to translate the name then it uses the dynamic string at \fI*bufferPtr\fR to hold the new string it generates. After \fBTcl_TranslateFileName\fR returns a non-NULL result, the caller must eventually invoke \fBTcl_DStringFree\fR to free any information placed in \fI*bufferPtr\fR. The caller need not know whether or not \fBTcl_TranslateFileName\fR actually used the string; \fBTcl_TranslateFileName\fR |
| ︙ | ︙ | |||
64 65 66 67 68 69 70 | \fBTcl_DStringFree\fR. .PP The caller is responsible for making sure that the interpreter's result has its default empty value when \fBTcl_TranslateFileName\fR is invoked. .SH "SEE ALSO" filename(n) .SH KEYWORDS | | | 64 65 66 67 68 69 70 71 | \fBTcl_DStringFree\fR. .PP The caller is responsible for making sure that the interpreter's result has its default empty value when \fBTcl_TranslateFileName\fR is invoked. .SH "SEE ALSO" filename(n) .SH KEYWORDS file name, home directory, translate, user |
Changes to doc/Utf.3.
| ︙ | ︙ | |||
130 131 132 133 134 135 136 | A null-terminated utf-16 string. .AP "const unsigned short" *utf16t in A null-terminated utf-16 string. .AP "const unsigned short" *utf16Pattern in A null-terminated utf-16 string. .AP size_t length in The length of the UTF-8 string in bytes (not UTF-8 characters). If | | | 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 | A null-terminated utf-16 string. .AP "const unsigned short" *utf16t in A null-terminated utf-16 string. .AP "const unsigned short" *utf16Pattern in A null-terminated utf-16 string. .AP size_t length in The length of the UTF-8 string in bytes (not UTF-8 characters). If TCL_INDEX_NONE, all bytes up to the first null byte are used. .AP size_t uniLength in The length of the Unicode string in characters. .AP "Tcl_DString" *dsPtr in/out A pointer to a previously initialized \fBTcl_DString\fR. .AP "const char" *start in Pointer to the beginning of a UTF-8 string. .AP size_t index in |
| ︙ | ︙ | |||
162 163 164 165 166 167 168 | consists of a lead byte followed by some number of trail bytes. .PP \fBTCL_UTF_MAX\fR is the maximum number of bytes that \fBTcl_UtfToUniChar\fR can consume in a single call. .PP \fBTcl_UniCharToUtf\fR stores the character \fIch\fR as a UTF-8 string in starting at \fIbuf\fR. The return value is the number of bytes stored | | > | | < | > | 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 | consists of a lead byte followed by some number of trail bytes. .PP \fBTCL_UTF_MAX\fR is the maximum number of bytes that \fBTcl_UtfToUniChar\fR can consume in a single call. .PP \fBTcl_UniCharToUtf\fR stores the character \fIch\fR as a UTF-8 string in starting at \fIbuf\fR. The return value is the number of bytes stored in \fIbuf\fR. The character \fIch\fR can be or'ed with the value TCL_COMBINE to enable special behavior, compatible with Tcl 8.x. Then, if ch is a high surrogate (range U+D800 - U+DBFF), the return value will be 1 and a single byte in the range 0xF0 - 0xF4 will be stored. If \fIch\fR is a low surrogate (range U+DC00 - U+DFFF), an attempt is made to combine the result with the earlier produced bytes, resulting in a 4-byte UTF-8 byte sequence. .PP \fBTcl_UtfToUniChar\fR reads one UTF-8 character starting at \fIsrc\fR and stores it as a Tcl_UniChar in \fI*chPtr\fR. The return value is the number of bytes read from \fIsrc\fR. The caller must ensure that the source buffer is long enough such that this routine does not run off the end and dereference non-existent or random memory; if the source buffer is known to be null-terminated, this will not happen. If the input is |
| ︙ | ︙ | |||
249 250 251 252 253 254 255 | does not guarantee that the UTF-8 string is properly formed. This routine is used by procedures that are operating on a byte at a time and need to know if a full Unicode character has been seen. .PP \fBTcl_NumUtfChars\fR corresponds to \fBstrlen\fR for UTF-8 strings. It returns the number of Tcl_UniChars that are represented by the UTF-8 string \fIsrc\fR. The length of the source string is \fIlength\fR bytes. If the | | | 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 | does not guarantee that the UTF-8 string is properly formed. This routine is used by procedures that are operating on a byte at a time and need to know if a full Unicode character has been seen. .PP \fBTcl_NumUtfChars\fR corresponds to \fBstrlen\fR for UTF-8 strings. It returns the number of Tcl_UniChars that are represented by the UTF-8 string \fIsrc\fR. The length of the source string is \fIlength\fR bytes. If the length is TCL_INDEX_NONE, all bytes up to the first null byte are used. .PP \fBTcl_UtfFindFirst\fR corresponds to \fBstrchr\fR for UTF-8 strings. It returns a pointer to the first occurrence of the Unicode character \fIch\fR in the null-terminated UTF-8 string \fIsrc\fR. The null terminator is considered part of the UTF-8 string. .PP \fBTcl_UtfFindLast\fR corresponds to \fBstrrchr\fR for UTF-8 strings. It |
| ︙ | ︙ |
Changes to doc/WrongNumArgs.3.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 | .sp \fBTcl_WrongNumArgs\fR(\fIinterp, objc, objv, message\fR) .SH ARGUMENTS .AS "Tcl_Obj *const" *message .AP Tcl_Interp interp in Interpreter in which error will be reported: error message gets stored in its result value. | | | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | .sp \fBTcl_WrongNumArgs\fR(\fIinterp, objc, objv, message\fR) .SH ARGUMENTS .AS "Tcl_Obj *const" *message .AP Tcl_Interp interp in Interpreter in which error will be reported: error message gets stored in its result value. .AP size_t objc in Number of leading arguments from \fIobjv\fR to include in error message. .AP "Tcl_Obj *const" objv[] in Arguments to command that had the wrong number of arguments. .AP "const char" *message in Additional error information to print after leading arguments from \fIobjv\fR. This typically gives the acceptable syntax |
| ︙ | ︙ |
Changes to doc/after.n.
| ︙ | ︙ | |||
29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | This command is used to delay execution of the program or to execute a command in background sometime in the future. It has several forms, depending on the first argument to the command: .TP \fBafter \fIms\fR . \fIMs\fR must be an integer giving a time in milliseconds. The command sleeps for \fIms\fR milliseconds and then returns. While the command is sleeping the application does not respond to events. .TP \fBafter \fIms \fR?\fIscript script script ...\fR? . In this form the command returns immediately, but it arranges for a Tcl command to be executed \fIms\fR milliseconds later as an event handler. The command will be executed exactly once, at the given time. The delayed command is formed by concatenating all the \fIscript\fR arguments in the same fashion as the \fBconcat\fR command. The command will be executed at global level (outside the context of any Tcl procedure). If an error occurs while executing the delayed command then the background error will be reported by the command registered with \fBinterp bgerror\fR. The \fBafter\fR command returns an identifier that can be used to cancel the delayed command using \fBafter cancel\fR. .TP \fBafter cancel \fIid\fR . Cancels the execution of a delayed command that was previously scheduled. \fIId\fR indicates which command should be canceled; it must have been the return value from a previous \fBafter\fR command. | > > > > | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | This command is used to delay execution of the program or to execute a command in background sometime in the future. It has several forms, depending on the first argument to the command: .TP \fBafter \fIms\fR . \fIMs\fR must be an integer giving a time in milliseconds. A negative number is treated as 0. The command sleeps for \fIms\fR milliseconds and then returns. While the command is sleeping the application does not respond to events. .TP \fBafter \fIms \fR?\fIscript script script ...\fR? . In this form the command returns immediately, but it arranges for a Tcl command to be executed \fIms\fR milliseconds later as an event handler. The command will be executed exactly once, at the given time. The delayed command is formed by concatenating all the \fIscript\fR arguments in the same fashion as the \fBconcat\fR command. The command will be executed at global level (outside the context of any Tcl procedure). If an error occurs while executing the delayed command then the background error will be reported by the command registered with \fBinterp bgerror\fR. The \fBafter\fR command returns an identifier that can be used to cancel the delayed command using \fBafter cancel\fR. A \fIms\fR value of 0 (or negative) queues the event immediately with priority over other event types (if not installed withn an event proc, which will wait for next round of events). .TP \fBafter cancel \fIid\fR . Cancels the execution of a delayed command that was previously scheduled. \fIId\fR indicates which command should be canceled; it must have been the return value from a previous \fBafter\fR command. |
| ︙ | ︙ |
Changes to doc/encoding.n.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | .SH NAME encoding \- Manipulate encodings .SH SYNOPSIS \fBencoding \fIoption\fR ?\fIarg arg ...\fR? .BE .SH INTRODUCTION .PP | | | | < < < < < < | > | | < | | > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > | 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 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 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 | .SH NAME encoding \- Manipulate encodings .SH SYNOPSIS \fBencoding \fIoption\fR ?\fIarg arg ...\fR? .BE .SH INTRODUCTION .PP Strings in Tcl are logically a sequence of Unicode characters. These strings are represented in memory as a sequence of bytes that may be in one of several encodings: modified UTF\-8 (which uses 1 to 4 bytes per character), or a custom encoding start as 8 bit binary data. .PP Different operating system interfaces or applications may generate strings in other encodings such as Shift\-JIS. The \fBencoding\fR command helps to bridge the gap between Unicode and these other formats. .SH DESCRIPTION .PP Performs one of several encoding related operations, depending on \fIoption\fR. The legal \fIoption\fRs are: .TP \fBencoding convertfrom\fR ?\fB-nocomplain\fR? ?\fB-failindex var\fR? ?\fIencoding\fR? \fIdata\fR . Convert \fIdata\fR to a Unicode string from the specified \fIencoding\fR. The characters in \fIdata\fR are 8 bit binary data. The resulting sequence of bytes is a string created by applying the given \fIencoding\fR to the data. If \fIencoding\fR is not specified, the current system encoding is used. . The call fails on convertion errors, like an incomplete utf-8 sequence. The option \fB-failindex\fR is followed by a variable name. The variable is set to \fI-1\fR if no conversion error occured. It is set to the first error location in \fIdata\fR in case of a conversion error. All data until this error location is transformed and retured. This option may not be used together with \fB-nocomplain\fR. . The call does not fail on conversion errors, if the option \fB-nocomplain\fR is given. In this case, any error locations are replaced by \fB?\fR. Incomplete sequences are written verbatim to the output string. The purpose of this switch is to gain compatibility to prior versions of TCL. It is not recommended for any other usage. .TP \fBencoding convertto\fR ?\fB-nocomplain\fR? ?\fB-failindex var\fR? ?\fIencoding\fR? \fIstring\fR . Convert \fIstring\fR from Unicode to the specified \fIencoding\fR. The result is a sequence of bytes that represents the converted string. Each byte is stored in the lower 8-bits of a Unicode character (indeed, the resulting string is a binary string as far as Tcl is concerned, at least initially). If \fIencoding\fR is not specified, the current system encoding is used. . The call fails on convertion errors, like a Unicode character not representable in the given \fIencoding\fR. . The option \fB-failindex\fR is followed by a variable name. The variable is set to \fI-1\fR if no conversion error occured. It is set to the first error location in \fIdata\fR in case of a conversion error. All data until this error location is transformed and retured. This option may not be used together with \fB-nocomplain\fR. . The call does not fail on conversion errors, if the option \fB-nocomplain\fR is given. In this case, any error locations are replaced by \fB?\fR. Incomplete sequences are written verbatim to the output string. The purpose of this switch is to gain compatibility to prior versions of TCL. It is not recommended for any other usage. .TP \fBencoding dirs\fR ?\fIdirectoryList\fR? . Tcl can load encoding data files from the file system that describe additional encodings for it to work with. This command sets the search path for \fB*.enc\fR encoding data files to the list of directories \fIdirectoryList\fR. If \fIdirectoryList\fR is omitted then the |
| ︙ | ︙ | |||
86 87 88 89 90 91 92 93 94 95 96 97 98 99 | .CS set s [\fBencoding convertfrom\fR euc-jp "\exA4\exCF"] .CE .PP The result is the unicode codepoint: .QW "\eu306F" , which is the Hiragana letter HA. .SH "SEE ALSO" Tcl_GetEncoding(3) .SH KEYWORDS encoding, unicode .\" Local Variables: .\" mode: nroff .\" End: | > > > > > > > > > > > > > > > > > > > > | 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 | .CS set s [\fBencoding convertfrom\fR euc-jp "\exA4\exCF"] .CE .PP The result is the unicode codepoint: .QW "\eu306F" , which is the Hiragana letter HA. .PP The following example detects the error location in an incomplete UTF-8 sequence: .PP .CS % set s [\fBencoding convertfrom\fR -failindex i utf-8 "A\exC3"] A % set i 1 .CE .PP The following example detects the error location while transforming to ISO8859-1 (ISO-Latin 1): .PP .CS % set s [\fBencoding convertto\fR -failindex i utf-8 "A\eu0141"] A % set i 1 .CE .PP .SH "SEE ALSO" Tcl_GetEncoding(3) .SH KEYWORDS encoding, unicode .\" Local Variables: .\" mode: nroff .\" End: |
Changes to doc/exec.n.
| ︙ | ︙ | |||
194 195 196 197 198 199 200 | The standard output from the last command in the pipeline will go to the application's standard output if it has not been redirected, and error output from all of the commands in the pipeline will go to the application's standard error file unless redirected. .PP The first word in each command is taken as the command name; | | | 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 | The standard output from the last command in the pipeline will go to the application's standard output if it has not been redirected, and error output from all of the commands in the pipeline will go to the application's standard error file unless redirected. .PP The first word in each command is taken as the command name; if the result contains no slashes then the directories in the PATH environment variable are searched for an executable by the given name. If the name contains a slash then it must refer to an executable reachable from the current directory. No .QW glob |
| ︙ | ︙ |
Changes to doc/file.n.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 | .SH NAME file \- Manipulate file names and attributes .SH SYNOPSIS \fBfile \fIoption\fR \fIname\fR ?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP | | | < < | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | .SH NAME file \- Manipulate file names and attributes .SH SYNOPSIS \fBfile \fIoption\fR \fIname\fR ?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP This command provides several operations on a file's name or attributes. The \fIname\fR argument is the name of a file in most cases. The \fIoption\fR argument indicates what to do with the file name. Any unique abbreviation for \fIoption\fR is acceptable. The valid options are: .TP \fBfile atime \fIname\fR ?\fItime\fR? . Returns a decimal string giving the time at which file \fIname\fR was last accessed. If \fItime\fR is specified, it is an access time to set for the file. The time is measured in the standard POSIX fashion as seconds from a fixed starting time (often January 1, 1970). If the file |
| ︙ | ︙ | |||
141 142 143 144 145 146 147 | .RS .PP .CS \fBfile dirname\fR c:/ .CE .PP returns \fBc:/\fR. | < < < < < < < < < < < < < < < > > > > > > > > > > > > > > > > > > | 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 | .RS .PP .CS \fBfile dirname\fR c:/ .CE .PP returns \fBc:/\fR. .RE .TP \fBfile executable \fIname\fR . Returns \fB1\fR if file \fIname\fR is executable by the current user, \fB0\fR otherwise. On Windows, which does not have an executable attribute, the command treats all directories and any files with extensions \fBexe\fR, \fBcom\fR, \fBcmd\fR or \fBbat\fR as executable. .TP \fBfile exists \fIname\fR . Returns \fB1\fR if file \fIname\fR exists and the current user has search privileges for the directories leading to it, \fB0\fR otherwise. .TP \fBfile extension \fIname\fR . Returns all of the characters in \fIname\fR after and including the last dot in the last element of \fIname\fR. If there is no dot in the last element of \fIname\fR then returns the empty string. .TP \fBfile home ?\fIusername\fR? .VS "8.7, TIP 602" If no argument is specified, the command returns the home directory of the current user. This is generally the value of the \fB$HOME\fR environment variable except that on Windows platforms backslashes in the path are replaced by forward slashes. An error is raised if the \fB$HOME\fR environment variable is not set. .RS .PP If \fIusername\fR is specified, the command returns the home directory configured in the system for the specified user. Note this may be different than the value of the \fB$HOME\fR environment variable even when \fIusername\fR corresponds to the current user. An error is raised if the \fIusername\fR does not correspond to a user account on the system. .RE .VE "8.7, TIP 602" .TP \fBfile isdirectory \fIname\fR . Returns \fB1\fR if file \fIname\fR is a directory, \fB0\fR otherwise. .TP \fBfile isfile \fIname\fR . |
| ︙ | ︙ | |||
375 376 377 378 379 380 381 | .TP \fBfile split \fIname\fR . Returns a list whose elements are the path components in \fIname\fR. The first element of the list will have the same path type as \fIname\fR. All other elements will be relative. Path separators will be discarded unless they are needed to ensure that an element is unambiguously relative. | < < < < < < < < < < < < < | 376 377 378 379 380 381 382 383 384 385 386 387 388 389 | .TP \fBfile split \fIname\fR . Returns a list whose elements are the path components in \fIname\fR. The first element of the list will have the same path type as \fIname\fR. All other elements will be relative. Path separators will be discarded unless they are needed to ensure that an element is unambiguously relative. .TP \fBfile stat \fIname varName\fR . Invokes the \fBstat\fR kernel call on \fIname\fR, and uses the variable given by \fIvarName\fR to hold information returned from the kernel call. \fIVarName\fR is treated as an array variable, and the following elements of that variable are set: \fBatime\fR, \fBctime\fR, \fBdev\fR, \fBgid\fR, |
| ︙ | ︙ | |||
478 479 480 481 482 483 484 485 486 487 488 489 490 491 | default instead. .RS .PP Note that temporary files are \fIonly\fR ever created on the native filesystem. As such, they can be relied upon to be used with operating-system native APIs and external programs that require a filename. .RE .TP \fBfile type \fIname\fR . Returns a string giving the type of file \fIname\fR, which will be one of \fBfile\fR, \fBdirectory\fR, \fBcharacterSpecial\fR, \fBblockSpecial\fR, \fBfifo\fR, \fBlink\fR, or \fBsocket\fR. .TP | > > > > > > > > > > > > > > > > | 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 | default instead. .RS .PP Note that temporary files are \fIonly\fR ever created on the native filesystem. As such, they can be relied upon to be used with operating-system native APIs and external programs that require a filename. .RE .TP \fBfile tildeexpand \fIname\fR .VS "8.7, TIP 602" Returns the result of performing tilde substitution on \fIname\fR. If the name begins with a tilde, then the file name will be interpreted as if the first element is replaced with the location of the home directory for the given user. If the tilde is followed immediately by a path separator, the \fB$HOME\fR environment variable is substituted. Otherwise the characters between the tilde and the next separator are taken as a user name, which is used to retrieve the user's home directory for substitution. An error is raised if the \fB$HOME\fR environment variable or user does not exist. .RS .PP If the file name does not begin with a tilde, it is returned unmodified. .RE .VE "8.7, TIP 602" .TP \fBfile type \fIname\fR . Returns a string giving the type of file \fIname\fR, which will be one of \fBfile\fR, \fBdirectory\fR, \fBcharacterSpecial\fR, \fBblockSpecial\fR, \fBfifo\fR, \fBlink\fR, or \fBsocket\fR. .TP |
| ︙ | ︙ |
Changes to doc/filename.n.
| ︙ | ︙ | |||
114 115 116 117 118 119 120 | volume. .TP 15 \fB\&\e\efoo\fR Volume-relative path to a file \fBfoo\fR in the root directory of the current volume. This is not a valid UNC path, so the assumption is that the extra backslashes are superfluous. .RE | < < < < < < < < < < < < < < < < < < < < | 114 115 116 117 118 119 120 121 122 123 124 125 126 127 | volume. .TP 15 \fB\&\e\efoo\fR Volume-relative path to a file \fBfoo\fR in the root directory of the current volume. This is not a valid UNC path, so the assumption is that the extra backslashes are superfluous. .RE .SH "PORTABILITY ISSUES" .PP Not all file systems are case sensitive, so scripts should avoid code that depends on the case of characters in a file name. In addition, the character sets allowed on different devices may differ, so scripts should choose file names that do not contain special characters like: \fB<>:?"/\e|\fR. |
| ︙ | ︙ |
Changes to doc/glob.n.
| ︙ | ︙ | |||
181 182 183 184 185 186 187 | .PP The \fBglob\fR command differs from csh globbing in two ways. First, it does not sort its result list (use the \fBlsort\fR command if you want the list sorted). Second, \fBglob\fR only returns the names of files that actually exist; in csh no check for existence is made unless a pattern contains a ?, *, or [] construct. | < < < < < < < < < < | 181 182 183 184 185 186 187 188 189 190 191 192 193 194 | .PP The \fBglob\fR command differs from csh globbing in two ways. First, it does not sort its result list (use the \fBlsort\fR command if you want the list sorted). Second, \fBglob\fR only returns the names of files that actually exist; in csh no check for existence is made unless a pattern contains a ?, *, or [] construct. .SH "WINDOWS PORTABILITY ISSUES" .PP For Windows UNC names, the servername and sharename components of the path may not contain ?, *, or [] constructs. On Windows NT, if \fIpattern\fR is of the form .QW \fB~\fIusername\fB@\fIdomain\fR , it refers to the home |
| ︙ | ︙ |
Changes to doc/http.n.
| ︙ | ︙ | |||
168 169 170 171 172 173 174 175 176 177 178 179 180 181 | request will be automatically retried; if boolean \fBfalse\fR it will not, and the application that uses \fBhttp::geturl\fR is expected to seek user confirmation before retrying the POST. The value \fBtrue\fR should be used only under certain conditions. See the \fBPERSISTENT SOCKETS\fR section for details. The default is 0. .TP \fB\-urlencoding\fR \fIencoding\fR . The \fIencoding\fR used for creating the x-url-encoded URLs with \fB::http::formatQuery\fR and \fB::http::quoteString\fR. The default is \fButf-8\fR, as specified by RFC 2718. .TP | > > > > > > > > > > > > > | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 | request will be automatically retried; if boolean \fBfalse\fR it will not, and the application that uses \fBhttp::geturl\fR is expected to seek user confirmation before retrying the POST. The value \fBtrue\fR should be used only under certain conditions. See the \fBPERSISTENT SOCKETS\fR section for details. The default is 0. .TP \fB\-threadlevel\fR \fIlevel\fR . Specifies whether and how to use the \fBThread\fR package. Possible values of \fIlevel\fR are 0, 1 or 2. .RS .PP .DS 0 - (the default) do not use Thread 1 - use Thread if it is available, do not use it if it is unavailable 2 - use Thread if it is available, raise an error if it is unavailable .DE The Tcl \fBsocket -async\fR command can block in adverse cases (e.g. a slow DNS lookup). Using the Thread package works around this problem, for both HTTP and HTTPS transactions. Values of \fIlevel\fR other than 0 are available only to the main interpreter in each thread. See section \fBTHREADS\fR for more information. .RE .TP \fB\-urlencoding\fR \fIencoding\fR . The \fIencoding\fR used for creating the x-url-encoded URLs with \fB::http::formatQuery\fR and \fB::http::quoteString\fR. The default is \fButf-8\fR, as specified by RFC 2718. .TP |
| ︙ | ︙ | |||
982 983 984 985 986 987 988 989 990 991 992 993 994 995 |
In browsers, opportunistic encryption is instead implemented by the
\fBUpgrade-Insecure-Requests\fR client header. If a secure service is available,
the server response code is a 307 redirect, and the response header
\fBLocation\fR specifies the target URL. The browser must call \fBhttp::geturl\fR
again in order to fetch this URL.
See https://w3c.github.io/webappsec-upgrade-insecure-requests/
.PP
.SH EXAMPLE
.PP
This example creates a procedure to copy a URL to a file while printing a
progress meter, and prints the meta-data associated with the URL.
.PP
.CS
proc httpcopy { url file {chunk 4096} } {
| > > > > > > > > > > > > > > | 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 |
In browsers, opportunistic encryption is instead implemented by the
\fBUpgrade-Insecure-Requests\fR client header. If a secure service is available,
the server response code is a 307 redirect, and the response header
\fBLocation\fR specifies the target URL. The browser must call \fBhttp::geturl\fR
again in order to fetch this URL.
See https://w3c.github.io/webappsec-upgrade-insecure-requests/
.PP
.SH THREADS
.PP
.SS "PURPOSE"
.PP
Command \fB::http::geturl\fR uses the Tcl \fB::socket\fR command with the \-async option to connect to a remote server, but the return from this command can be delayed in adverse cases (e.g. a slow DNS lookup), preventing the event loop from processing other events. This delay is avoided if the \fB::socket\fR command is evaluated in another thread. The Thread package is not part of Tcl but is provided in "Batteries Included" distributions. Instead of the \fB::socket\fR command, the http package uses \fB::http::socket\fR which makes connections in the manner specified by the value of \-threadlevel and the availability of package Thread.
.PP
.SS "WITH TLS (HTTPS)"
.PP
The same \-threadlevel configuration applies to both HTTP and HTTPS connections. HTTPS is enabled by using the \fBhttp::register\fR command, typically by specifying the \fB::tls::socket\fR command of the tls package to handle TLS cryptography. The \fB::tls::socket\fR command connects to the remote server by using the command specified by the value of variable \fB::tls::socketCmd\fR, and this value defaults to "::socket". If http::geturl finds that \fB::tls::socketCmd\fR has this value, it replaces it with the value "::http::socket". If \fB::tls::socketCmd\fR has a value other than "::socket", i.e. if the script or the Tcl installation has replaced the value "::socket" with the name of a different command, then http does not change the value. The script or installation that modified \fB::tls::socketCmd\fR is responsible for integrating \fB::http::socket\fR into its own replacement command.
.PP
.SS "WITH A CHILD INTERPRETER"
.PP
The peer thread can transfer the socket only to the main interpreter of the script's thread. Therefore the thread-based \fB::http::socket\fR works with non-zero \-threadlevel values only if the script runs in the main interpreter. A child interpreter must use \-threadlevel 0 unless the parent interpreter has provided alternative facilities. The main parent interpreter may grant full \-threadlevel facilities to a child interpreter, for example by aliasing, to \fB::http::socket\fR in the child, a command that runs \fBhttp::socket\fR in the parent, and then transfers the socket to the child.
.PP
.SH EXAMPLE
.PP
This example creates a procedure to copy a URL to a file while printing a
progress meter, and prints the meta-data associated with the URL.
.PP
.CS
proc httpcopy { url file {chunk 4096} } {
|
| ︙ | ︙ |
Changes to doc/info.n.
| ︙ | ︙ | |||
64 65 66 67 68 69 70 | that represents an instance of \fBoo::object\fR or one of its subclasses. .IP \fBproc\fR \fIcommandName\fR was created by \fBproc\fR. .IP \fBinterp\fR \fIcommandName\fR was created by \fBinterp create\fR. .IP \fBzlibStream\fR \fIcommandName\fR was created by \fBzlib stream\fR. | < < | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 | that represents an instance of \fBoo::object\fR or one of its subclasses. .IP \fBproc\fR \fIcommandName\fR was created by \fBproc\fR. .IP \fBinterp\fR \fIcommandName\fR was created by \fBinterp create\fR. .IP \fBzlibStream\fR \fIcommandName\fR was created by \fBzlib stream\fR. .RE .VE TIP426 .TP \fBinfo commands \fR?\fIpattern\fR? . Returns the names of all commands visible in the current namespace. If \fIpattern\fR is given, returns only those names that match according to |
| ︙ | ︙ |
Changes to doc/msgcat.n.
| ︙ | ︙ | |||
69 70 71 72 73 74 75 | .QW "message catalog" which is independent from the application, and which can be edited or localized without modifying the application source code. New languages or locales may be provided by adding a new file to the message catalog. .PP | | | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | .QW "message catalog" which is independent from the application, and which can be edited or localized without modifying the application source code. New languages or locales may be provided by adding a new file to the message catalog. .PP \fBmsgcat\fR distinguishes packages by its namespace. Each package has its own message catalog and configuration settings in \fBmsgcat\fR. .PP A \fIlocale\fR is a specification string describing a user language like \fBde_ch\fR for Swiss German. In \fBmsgcat\fR, there is a global locale initialized by the system locale of the current system. Each package may decide to use the global locale or to use a package specific locale. .PP The global locale may be changed on demand, for example by a user initiated language change or within a multi user application like a web server. |
| ︙ | ︙ | |||
220 221 222 223 224 225 226 | .VS "TIP 499" .TP \fB::msgcat::mcloadedlocales subcommand\fR ?\fIlocale\fR? . This group of commands manage the list of loaded locales for packages not setting a package locale. .PP .RS | | < < | | 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 | .VS "TIP 499" .TP \fB::msgcat::mcloadedlocales subcommand\fR ?\fIlocale\fR? . This group of commands manage the list of loaded locales for packages not setting a package locale. .PP .RS The subcommand \fBloaded\fR returns the list of currently loaded locales. .PP The subcommand \fBclear\fR removes all locales and their data, which are not in the current preference list. .RE .TP \fB::msgcat::mcload \fIdirname\fR . .VS "TIP 412" Searches the specified directory for files that match the language specifications returned by \fB::msgcat::mcloadedlocales loaded\fR (or \fBmsgcat::mcpackagelocale preferences\fR if a package locale is set) (note that these are all lowercase), extended by the file extension .QW .msg . Each matching file is read in order, assuming a UTF-8 encoding. The file contents are then evaluated as a Tcl script. This means that Unicode characters may be present in the message file either directly in their UTF-8 encoded form, or by use of the backslash-u quoting recognized by Tcl |
| ︙ | ︙ |
Changes to generic/regc_color.c.
| ︙ | ︙ | |||
755 756 757 758 759 760 761 |
struct colormap *cm,
FILE *f)
{
struct colordesc *cd;
struct colordesc *end;
color co;
chr c;
| | | | 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 |
struct colormap *cm,
FILE *f)
{
struct colordesc *cd;
struct colordesc *end;
color co;
chr c;
const char *has;
fprintf(f, "max %" TCL_Z_MODIFIER "u\n", cm->max);
if (NBYTS > 1) {
fillcheck(cm, cm->tree, 0, f);
}
end = CDEND(cm);
for (cd=cm->cd+1, co=1 ; cd<end ; cd++, co++) { /* skip 0 */
if (!UNUSEDCOLOR(cd)) {
assert(cd->nchrs > 0);
|
| ︙ | ︙ |
Changes to generic/regc_cvec.c.
| ︙ | ︙ | |||
32 33 34 35 36 37 38 | /* * Notes: * Only (selected) functions in _this_ file should treat chr* as non-constant. */ /* - newcvec - allocate a new cvec | | | | | | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
/*
* Notes:
* Only (selected) functions in _this_ file should treat chr* as non-constant.
*/
/*
- newcvec - allocate a new cvec
^ static struct cvec *newcvec(size_t, size_t);
*/
static struct cvec *
newcvec(
size_t nchrs, /* to hold this many chrs... */
size_t nranges) /* ... and this many ranges... */
{
size_t nc = nchrs + nranges*2;
size_t n = sizeof(struct cvec) + nc*sizeof(chr);
struct cvec *cv = (struct cvec *) MALLOC(n);
if (cv == NULL) {
return NULL;
}
cv->chrspace = nchrs;
|
| ︙ | ︙ | |||
104 105 106 107 108 109 110 |
/*
- getcvec - get a cvec, remembering it as v->cv
^ static struct cvec *getcvec(struct vars *, int, int);
*/
static struct cvec *
getcvec(
struct vars *v, /* context */
| | | | 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 |
/*
- getcvec - get a cvec, remembering it as v->cv
^ static struct cvec *getcvec(struct vars *, int, int);
*/
static struct cvec *
getcvec(
struct vars *v, /* context */
size_t nchrs, /* to hold this many chrs... */
size_t nranges) /* ... and this many ranges... */
{
if ((v->cv != NULL) && (nchrs <= v->cv->chrspace) &&
(nranges <= v->cv->rangespace)) {
return clearcvec(v->cv);
}
if (v->cv != NULL) {
|
| ︙ | ︙ |
Changes to generic/regc_locale.c.
| ︙ | ︙ | |||
223 224 225 226 227 228 229 |
{0x1135D, 0x11361}, {0x11400, 0x11434}, {0x11447, 0x1144A}, {0x1145F, 0x11461},
{0x11480, 0x114AF}, {0x11580, 0x115AE}, {0x115D8, 0x115DB}, {0x11600, 0x1162F},
{0x11680, 0x116AA}, {0x11700, 0x1171A}, {0x11740, 0x11746}, {0x11800, 0x1182B},
{0x118A0, 0x118DF}, {0x118FF, 0x11906}, {0x1190C, 0x11913}, {0x11918, 0x1192F},
{0x119A0, 0x119A7}, {0x119AA, 0x119D0}, {0x11A0B, 0x11A32}, {0x11A5C, 0x11A89},
{0x11AB0, 0x11AF8}, {0x11C00, 0x11C08}, {0x11C0A, 0x11C2E}, {0x11C72, 0x11C8F},
{0x11D00, 0x11D06}, {0x11D0B, 0x11D30}, {0x11D60, 0x11D65}, {0x11D6A, 0x11D89},
| > | | | | | | | | | | | | | | | | | | | | | | > | 223 224 225 226 227 228 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 |
{0x1135D, 0x11361}, {0x11400, 0x11434}, {0x11447, 0x1144A}, {0x1145F, 0x11461},
{0x11480, 0x114AF}, {0x11580, 0x115AE}, {0x115D8, 0x115DB}, {0x11600, 0x1162F},
{0x11680, 0x116AA}, {0x11700, 0x1171A}, {0x11740, 0x11746}, {0x11800, 0x1182B},
{0x118A0, 0x118DF}, {0x118FF, 0x11906}, {0x1190C, 0x11913}, {0x11918, 0x1192F},
{0x119A0, 0x119A7}, {0x119AA, 0x119D0}, {0x11A0B, 0x11A32}, {0x11A5C, 0x11A89},
{0x11AB0, 0x11AF8}, {0x11C00, 0x11C08}, {0x11C0A, 0x11C2E}, {0x11C72, 0x11C8F},
{0x11D00, 0x11D06}, {0x11D0B, 0x11D30}, {0x11D60, 0x11D65}, {0x11D6A, 0x11D89},
{0x11EE0, 0x11EF2}, {0x11F04, 0x11F10}, {0x11F12, 0x11F33}, {0x12000, 0x12399},
{0x12480, 0x12543}, {0x12F90, 0x12FF0}, {0x13000, 0x1342F}, {0x13441, 0x13446},
{0x14400, 0x14646}, {0x16800, 0x16A38}, {0x16A40, 0x16A5E}, {0x16A70, 0x16ABE},
{0x16AD0, 0x16AED}, {0x16B00, 0x16B2F}, {0x16B40, 0x16B43}, {0x16B63, 0x16B77},
{0x16B7D, 0x16B8F}, {0x16E40, 0x16E7F}, {0x16F00, 0x16F4A}, {0x16F93, 0x16F9F},
{0x17000, 0x187F7}, {0x18800, 0x18CD5}, {0x18D00, 0x18D08}, {0x1AFF0, 0x1AFF3},
{0x1AFF5, 0x1AFFB}, {0x1B000, 0x1B122}, {0x1B150, 0x1B152}, {0x1B164, 0x1B167},
{0x1B170, 0x1B2FB}, {0x1BC00, 0x1BC6A}, {0x1BC70, 0x1BC7C}, {0x1BC80, 0x1BC88},
{0x1BC90, 0x1BC99}, {0x1D400, 0x1D454}, {0x1D456, 0x1D49C}, {0x1D4A9, 0x1D4AC},
{0x1D4AE, 0x1D4B9}, {0x1D4BD, 0x1D4C3}, {0x1D4C5, 0x1D505}, {0x1D507, 0x1D50A},
{0x1D50D, 0x1D514}, {0x1D516, 0x1D51C}, {0x1D51E, 0x1D539}, {0x1D53B, 0x1D53E},
{0x1D540, 0x1D544}, {0x1D54A, 0x1D550}, {0x1D552, 0x1D6A5}, {0x1D6A8, 0x1D6C0},
{0x1D6C2, 0x1D6DA}, {0x1D6DC, 0x1D6FA}, {0x1D6FC, 0x1D714}, {0x1D716, 0x1D734},
{0x1D736, 0x1D74E}, {0x1D750, 0x1D76E}, {0x1D770, 0x1D788}, {0x1D78A, 0x1D7A8},
{0x1D7AA, 0x1D7C2}, {0x1D7C4, 0x1D7CB}, {0x1DF00, 0x1DF1E}, {0x1DF25, 0x1DF2A},
{0x1E030, 0x1E06D}, {0x1E100, 0x1E12C}, {0x1E137, 0x1E13D}, {0x1E290, 0x1E2AD},
{0x1E2C0, 0x1E2EB}, {0x1E4D0, 0x1E4EB}, {0x1E7E0, 0x1E7E6}, {0x1E7E8, 0x1E7EB},
{0x1E7F0, 0x1E7FE}, {0x1E800, 0x1E8C4}, {0x1E900, 0x1E943}, {0x1EE00, 0x1EE03},
{0x1EE05, 0x1EE1F}, {0x1EE29, 0x1EE32}, {0x1EE34, 0x1EE37}, {0x1EE4D, 0x1EE4F},
{0x1EE67, 0x1EE6A}, {0x1EE6C, 0x1EE72}, {0x1EE74, 0x1EE77}, {0x1EE79, 0x1EE7C},
{0x1EE80, 0x1EE89}, {0x1EE8B, 0x1EE9B}, {0x1EEA1, 0x1EEA3}, {0x1EEA5, 0x1EEA9},
{0x1EEAB, 0x1EEBB}, {0x20000, 0x2A6DF}, {0x2A700, 0x2B739}, {0x2B740, 0x2B81D},
{0x2B820, 0x2CEA1}, {0x2CEB0, 0x2EBE0}, {0x2F800, 0x2FA1D}, {0x30000, 0x3134A},
{0x31350, 0x323AF}
#endif
};
#define NUM_ALPHA_RANGE (sizeof(alphaRangeTable)/sizeof(crange))
static const chr alphaCharTable[] = {
0xAA, 0xB5, 0xBA, 0x2EC, 0x2EE, 0x376, 0x377, 0x37F, 0x386,
|
| ︙ | ︙ | |||
272 273 274 275 276 277 278 |
0x2126, 0x2128, 0x214E, 0x2183, 0x2184, 0x2CF2, 0x2CF3, 0x2D27, 0x2D2D,
0x2D6F, 0x2E2F, 0x3005, 0x3006, 0x303B, 0x303C, 0xA62A, 0xA62B, 0xA7D0,
0xA7D1, 0xA7D3, 0xA8FB, 0xA8FD, 0xA8FE, 0xA9CF, 0xAA7A, 0xAAB1, 0xAAB5,
0xAAB6, 0xAAC0, 0xAAC2, 0xFB1D, 0xFB3E, 0xFB40, 0xFB41, 0xFB43, 0xFB44
#if CHRBITS > 16
,0x1003C, 0x1003D, 0x10594, 0x10595, 0x105BB, 0x105BC, 0x10808, 0x10837, 0x10838,
0x1083C, 0x108F4, 0x108F5, 0x109BE, 0x109BF, 0x10A00, 0x10EB0, 0x10EB1, 0x10F27,
| | | | | | > | | | | | | 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 |
0x2126, 0x2128, 0x214E, 0x2183, 0x2184, 0x2CF2, 0x2CF3, 0x2D27, 0x2D2D,
0x2D6F, 0x2E2F, 0x3005, 0x3006, 0x303B, 0x303C, 0xA62A, 0xA62B, 0xA7D0,
0xA7D1, 0xA7D3, 0xA8FB, 0xA8FD, 0xA8FE, 0xA9CF, 0xAA7A, 0xAAB1, 0xAAB5,
0xAAB6, 0xAAC0, 0xAAC2, 0xFB1D, 0xFB3E, 0xFB40, 0xFB41, 0xFB43, 0xFB44
#if CHRBITS > 16
,0x1003C, 0x1003D, 0x10594, 0x10595, 0x105BB, 0x105BC, 0x10808, 0x10837, 0x10838,
0x1083C, 0x108F4, 0x108F5, 0x109BE, 0x109BF, 0x10A00, 0x10EB0, 0x10EB1, 0x10F27,
0x11071, 0x11072, 0x11075, 0x11144, 0x11147, 0x11176, 0x111DA, 0x111DC, 0x1123F,
0x11240, 0x11288, 0x1130F, 0x11310, 0x11332, 0x11333, 0x1133D, 0x11350, 0x114C4,
0x114C5, 0x114C7, 0x11644, 0x116B8, 0x11909, 0x11915, 0x11916, 0x1193F, 0x11941,
0x119E1, 0x119E3, 0x11A00, 0x11A3A, 0x11A50, 0x11A9D, 0x11C40, 0x11D08, 0x11D09,
0x11D46, 0x11D67, 0x11D68, 0x11D98, 0x11F02, 0x11FB0, 0x16F50, 0x16FE0, 0x16FE1,
0x16FE3, 0x1AFFD, 0x1AFFE, 0x1B132, 0x1B155, 0x1D49E, 0x1D49F, 0x1D4A2, 0x1D4A5,
0x1D4A6, 0x1D4BB, 0x1D546, 0x1E14E, 0x1E7ED, 0x1E7EE, 0x1E94B, 0x1EE21, 0x1EE22,
0x1EE24, 0x1EE27, 0x1EE39, 0x1EE3B, 0x1EE42, 0x1EE47, 0x1EE49, 0x1EE4B, 0x1EE51,
0x1EE52, 0x1EE54, 0x1EE57, 0x1EE59, 0x1EE5B, 0x1EE5D, 0x1EE5F, 0x1EE61, 0x1EE62,
0x1EE64, 0x1EE7E
#endif
};
#define NUM_ALPHA_CHAR (sizeof(alphaCharTable)/sizeof(chr))
/*
* Unicode: control characters.
*/
static const crange controlRangeTable[] = {
{0x0, 0x1F}, {0x7F, 0x9F}, {0x600, 0x605}, {0x200B, 0x200F},
{0x202A, 0x202E}, {0x2060, 0x2064}, {0x2066, 0x206F}, {0xE000, 0xF8FF},
{0xFFF9, 0xFFFB}
#if CHRBITS > 16
,{0x13430, 0x1343F}, {0x1BCA0, 0x1BCA3}, {0x1D173, 0x1D17A}, {0xE0020, 0xE007F},
{0xF0000, 0xFFFFD}, {0x100000, 0x10FFFD}
#endif
};
#define NUM_CONTROL_RANGE (sizeof(controlRangeTable)/sizeof(crange))
static const chr controlCharTable[] = {
|
| ︙ | ︙ | |||
331 332 333 334 335 336 337 |
{0xA9D0, 0xA9D9}, {0xA9F0, 0xA9F9}, {0xAA50, 0xAA59}, {0xABF0, 0xABF9},
{0xFF10, 0xFF19}
#if CHRBITS > 16
,{0x104A0, 0x104A9}, {0x10D30, 0x10D39}, {0x11066, 0x1106F}, {0x110F0, 0x110F9},
{0x11136, 0x1113F}, {0x111D0, 0x111D9}, {0x112F0, 0x112F9}, {0x11450, 0x11459},
{0x114D0, 0x114D9}, {0x11650, 0x11659}, {0x116C0, 0x116C9}, {0x11730, 0x11739},
{0x118E0, 0x118E9}, {0x11950, 0x11959}, {0x11C50, 0x11C59}, {0x11D50, 0x11D59},
| | | | | 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 |
{0xA9D0, 0xA9D9}, {0xA9F0, 0xA9F9}, {0xAA50, 0xAA59}, {0xABF0, 0xABF9},
{0xFF10, 0xFF19}
#if CHRBITS > 16
,{0x104A0, 0x104A9}, {0x10D30, 0x10D39}, {0x11066, 0x1106F}, {0x110F0, 0x110F9},
{0x11136, 0x1113F}, {0x111D0, 0x111D9}, {0x112F0, 0x112F9}, {0x11450, 0x11459},
{0x114D0, 0x114D9}, {0x11650, 0x11659}, {0x116C0, 0x116C9}, {0x11730, 0x11739},
{0x118E0, 0x118E9}, {0x11950, 0x11959}, {0x11C50, 0x11C59}, {0x11D50, 0x11D59},
{0x11DA0, 0x11DA9}, {0x11F50, 0x11F59}, {0x16A60, 0x16A69}, {0x16AC0, 0x16AC9},
{0x16B50, 0x16B59}, {0x1D7CE, 0x1D7FF}, {0x1E140, 0x1E149}, {0x1E2F0, 0x1E2F9},
{0x1E4F0, 0x1E4F9}, {0x1E950, 0x1E959}, {0x1FBF0, 0x1FBF9}
#endif
};
#define NUM_DIGIT_RANGE (sizeof(digitRangeTable)/sizeof(crange))
/*
* no singletons of digit characters.
|
| ︙ | ︙ | |||
368 369 370 371 372 373 374 |
{0xFF0C, 0xFF0F}, {0xFF3B, 0xFF3D}, {0xFF5F, 0xFF65}
#if CHRBITS > 16
,{0x10100, 0x10102}, {0x10A50, 0x10A58}, {0x10AF0, 0x10AF6}, {0x10B39, 0x10B3F},
{0x10B99, 0x10B9C}, {0x10F55, 0x10F59}, {0x10F86, 0x10F89}, {0x11047, 0x1104D},
{0x110BE, 0x110C1}, {0x11140, 0x11143}, {0x111C5, 0x111C8}, {0x111DD, 0x111DF},
{0x11238, 0x1123D}, {0x1144B, 0x1144F}, {0x115C1, 0x115D7}, {0x11641, 0x11643},
{0x11660, 0x1166C}, {0x1173C, 0x1173E}, {0x11944, 0x11946}, {0x11A3F, 0x11A46},
| | | > | 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 |
{0xFF0C, 0xFF0F}, {0xFF3B, 0xFF3D}, {0xFF5F, 0xFF65}
#if CHRBITS > 16
,{0x10100, 0x10102}, {0x10A50, 0x10A58}, {0x10AF0, 0x10AF6}, {0x10B39, 0x10B3F},
{0x10B99, 0x10B9C}, {0x10F55, 0x10F59}, {0x10F86, 0x10F89}, {0x11047, 0x1104D},
{0x110BE, 0x110C1}, {0x11140, 0x11143}, {0x111C5, 0x111C8}, {0x111DD, 0x111DF},
{0x11238, 0x1123D}, {0x1144B, 0x1144F}, {0x115C1, 0x115D7}, {0x11641, 0x11643},
{0x11660, 0x1166C}, {0x1173C, 0x1173E}, {0x11944, 0x11946}, {0x11A3F, 0x11A46},
{0x11A9A, 0x11A9C}, {0x11A9E, 0x11AA2}, {0x11B00, 0x11B09}, {0x11C41, 0x11C45},
{0x11F43, 0x11F4F}, {0x12470, 0x12474}, {0x16B37, 0x16B3B}, {0x16E97, 0x16E9A},
{0x1DA87, 0x1DA8B}
#endif
};
#define NUM_PUNCT_RANGE (sizeof(punctRangeTable)/sizeof(crange))
static const chr punctCharTable[] = {
0x3A, 0x3B, 0x3F, 0x40, 0x5F, 0x7B, 0x7D, 0xA1, 0xA7,
|
| ︙ | ︙ | |||
445 446 447 448 449 450 451 |
{0x1D41A, 0x1D433}, {0x1D44E, 0x1D454}, {0x1D456, 0x1D467}, {0x1D482, 0x1D49B},
{0x1D4B6, 0x1D4B9}, {0x1D4BD, 0x1D4C3}, {0x1D4C5, 0x1D4CF}, {0x1D4EA, 0x1D503},
{0x1D51E, 0x1D537}, {0x1D552, 0x1D56B}, {0x1D586, 0x1D59F}, {0x1D5BA, 0x1D5D3},
{0x1D5EE, 0x1D607}, {0x1D622, 0x1D63B}, {0x1D656, 0x1D66F}, {0x1D68A, 0x1D6A5},
{0x1D6C2, 0x1D6DA}, {0x1D6DC, 0x1D6E1}, {0x1D6FC, 0x1D714}, {0x1D716, 0x1D71B},
{0x1D736, 0x1D74E}, {0x1D750, 0x1D755}, {0x1D770, 0x1D788}, {0x1D78A, 0x1D78F},
{0x1D7AA, 0x1D7C2}, {0x1D7C4, 0x1D7C9}, {0x1DF00, 0x1DF09}, {0x1DF0B, 0x1DF1E},
| | | 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 |
{0x1D41A, 0x1D433}, {0x1D44E, 0x1D454}, {0x1D456, 0x1D467}, {0x1D482, 0x1D49B},
{0x1D4B6, 0x1D4B9}, {0x1D4BD, 0x1D4C3}, {0x1D4C5, 0x1D4CF}, {0x1D4EA, 0x1D503},
{0x1D51E, 0x1D537}, {0x1D552, 0x1D56B}, {0x1D586, 0x1D59F}, {0x1D5BA, 0x1D5D3},
{0x1D5EE, 0x1D607}, {0x1D622, 0x1D63B}, {0x1D656, 0x1D66F}, {0x1D68A, 0x1D6A5},
{0x1D6C2, 0x1D6DA}, {0x1D6DC, 0x1D6E1}, {0x1D6FC, 0x1D714}, {0x1D716, 0x1D71B},
{0x1D736, 0x1D74E}, {0x1D750, 0x1D755}, {0x1D770, 0x1D788}, {0x1D78A, 0x1D78F},
{0x1D7AA, 0x1D7C2}, {0x1D7C4, 0x1D7C9}, {0x1DF00, 0x1DF09}, {0x1DF0B, 0x1DF1E},
{0x1DF25, 0x1DF2A}, {0x1E922, 0x1E943}
#endif
};
#define NUM_LOWER_RANGE (sizeof(lowerRangeTable)/sizeof(crange))
static const chr lowerCharTable[] = {
0xB5, 0x101, 0x103, 0x105, 0x107, 0x109, 0x10B, 0x10D, 0x10F,
|
| ︙ | ︙ | |||
656 657 658 659 660 661 662 |
{0xB85, 0xB8A}, {0xB8E, 0xB90}, {0xB92, 0xB95}, {0xBA8, 0xBAA},
{0xBAE, 0xBB9}, {0xBBE, 0xBC2}, {0xBC6, 0xBC8}, {0xBCA, 0xBCD},
{0xBE6, 0xBFA}, {0xC00, 0xC0C}, {0xC0E, 0xC10}, {0xC12, 0xC28},
{0xC2A, 0xC39}, {0xC3C, 0xC44}, {0xC46, 0xC48}, {0xC4A, 0xC4D},
{0xC58, 0xC5A}, {0xC60, 0xC63}, {0xC66, 0xC6F}, {0xC77, 0xC8C},
{0xC8E, 0xC90}, {0xC92, 0xCA8}, {0xCAA, 0xCB3}, {0xCB5, 0xCB9},
{0xCBC, 0xCC4}, {0xCC6, 0xCC8}, {0xCCA, 0xCCD}, {0xCE0, 0xCE3},
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 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 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 |
{0xB85, 0xB8A}, {0xB8E, 0xB90}, {0xB92, 0xB95}, {0xBA8, 0xBAA},
{0xBAE, 0xBB9}, {0xBBE, 0xBC2}, {0xBC6, 0xBC8}, {0xBCA, 0xBCD},
{0xBE6, 0xBFA}, {0xC00, 0xC0C}, {0xC0E, 0xC10}, {0xC12, 0xC28},
{0xC2A, 0xC39}, {0xC3C, 0xC44}, {0xC46, 0xC48}, {0xC4A, 0xC4D},
{0xC58, 0xC5A}, {0xC60, 0xC63}, {0xC66, 0xC6F}, {0xC77, 0xC8C},
{0xC8E, 0xC90}, {0xC92, 0xCA8}, {0xCAA, 0xCB3}, {0xCB5, 0xCB9},
{0xCBC, 0xCC4}, {0xCC6, 0xCC8}, {0xCCA, 0xCCD}, {0xCE0, 0xCE3},
{0xCE6, 0xCEF}, {0xCF1, 0xCF3}, {0xD00, 0xD0C}, {0xD0E, 0xD10},
{0xD12, 0xD44}, {0xD46, 0xD48}, {0xD4A, 0xD4F}, {0xD54, 0xD63},
{0xD66, 0xD7F}, {0xD81, 0xD83}, {0xD85, 0xD96}, {0xD9A, 0xDB1},
{0xDB3, 0xDBB}, {0xDC0, 0xDC6}, {0xDCF, 0xDD4}, {0xDD8, 0xDDF},
{0xDE6, 0xDEF}, {0xDF2, 0xDF4}, {0xE01, 0xE3A}, {0xE3F, 0xE5B},
{0xE86, 0xE8A}, {0xE8C, 0xEA3}, {0xEA7, 0xEBD}, {0xEC0, 0xEC4},
{0xEC8, 0xECE}, {0xED0, 0xED9}, {0xEDC, 0xEDF}, {0xF00, 0xF47},
{0xF49, 0xF6C}, {0xF71, 0xF97}, {0xF99, 0xFBC}, {0xFBE, 0xFCC},
{0xFCE, 0xFDA}, {0x1000, 0x10C5}, {0x10D0, 0x1248}, {0x124A, 0x124D},
{0x1250, 0x1256}, {0x125A, 0x125D}, {0x1260, 0x1288}, {0x128A, 0x128D},
{0x1290, 0x12B0}, {0x12B2, 0x12B5}, {0x12B8, 0x12BE}, {0x12C2, 0x12C5},
{0x12C8, 0x12D6}, {0x12D8, 0x1310}, {0x1312, 0x1315}, {0x1318, 0x135A},
{0x135D, 0x137C}, {0x1380, 0x1399}, {0x13A0, 0x13F5}, {0x13F8, 0x13FD},
{0x1400, 0x167F}, {0x1681, 0x169C}, {0x16A0, 0x16F8}, {0x1700, 0x1715},
{0x171F, 0x1736}, {0x1740, 0x1753}, {0x1760, 0x176C}, {0x176E, 0x1770},
{0x1780, 0x17DD}, {0x17E0, 0x17E9}, {0x17F0, 0x17F9}, {0x1800, 0x180D},
{0x180F, 0x1819}, {0x1820, 0x1878}, {0x1880, 0x18AA}, {0x18B0, 0x18F5},
{0x1900, 0x191E}, {0x1920, 0x192B}, {0x1930, 0x193B}, {0x1944, 0x196D},
{0x1970, 0x1974}, {0x1980, 0x19AB}, {0x19B0, 0x19C9}, {0x19D0, 0x19DA},
{0x19DE, 0x1A1B}, {0x1A1E, 0x1A5E}, {0x1A60, 0x1A7C}, {0x1A7F, 0x1A89},
{0x1A90, 0x1A99}, {0x1AA0, 0x1AAD}, {0x1AB0, 0x1ACE}, {0x1B00, 0x1B4C},
{0x1B50, 0x1B7E}, {0x1B80, 0x1BF3}, {0x1BFC, 0x1C37}, {0x1C3B, 0x1C49},
{0x1C4D, 0x1C88}, {0x1C90, 0x1CBA}, {0x1CBD, 0x1CC7}, {0x1CD0, 0x1CFA},
{0x1D00, 0x1F15}, {0x1F18, 0x1F1D}, {0x1F20, 0x1F45}, {0x1F48, 0x1F4D},
{0x1F50, 0x1F57}, {0x1F5F, 0x1F7D}, {0x1F80, 0x1FB4}, {0x1FB6, 0x1FC4},
{0x1FC6, 0x1FD3}, {0x1FD6, 0x1FDB}, {0x1FDD, 0x1FEF}, {0x1FF2, 0x1FF4},
{0x1FF6, 0x1FFE}, {0x2010, 0x2027}, {0x2030, 0x205E}, {0x2074, 0x208E},
{0x2090, 0x209C}, {0x20A0, 0x20C0}, {0x20D0, 0x20F0}, {0x2100, 0x218B},
{0x2190, 0x2426}, {0x2440, 0x244A}, {0x2460, 0x2B73}, {0x2B76, 0x2B95},
{0x2B97, 0x2CF3}, {0x2CF9, 0x2D25}, {0x2D30, 0x2D67}, {0x2D7F, 0x2D96},
{0x2DA0, 0x2DA6}, {0x2DA8, 0x2DAE}, {0x2DB0, 0x2DB6}, {0x2DB8, 0x2DBE},
{0x2DC0, 0x2DC6}, {0x2DC8, 0x2DCE}, {0x2DD0, 0x2DD6}, {0x2DD8, 0x2DDE},
{0x2DE0, 0x2E5D}, {0x2E80, 0x2E99}, {0x2E9B, 0x2EF3}, {0x2F00, 0x2FD5},
{0x2FF0, 0x2FFB}, {0x3001, 0x303F}, {0x3041, 0x3096}, {0x3099, 0x30FF},
{0x3105, 0x312F}, {0x3131, 0x318E}, {0x3190, 0x31E3}, {0x31F0, 0x321E},
{0x3220, 0xA48C}, {0xA490, 0xA4C6}, {0xA4D0, 0xA62B}, {0xA640, 0xA6F7},
{0xA700, 0xA7CA}, {0xA7D5, 0xA7D9}, {0xA7F2, 0xA82C}, {0xA830, 0xA839},
{0xA840, 0xA877}, {0xA880, 0xA8C5}, {0xA8CE, 0xA8D9}, {0xA8E0, 0xA953},
{0xA95F, 0xA97C}, {0xA980, 0xA9CD}, {0xA9CF, 0xA9D9}, {0xA9DE, 0xA9FE},
{0xAA00, 0xAA36}, {0xAA40, 0xAA4D}, {0xAA50, 0xAA59}, {0xAA5C, 0xAAC2},
{0xAADB, 0xAAF6}, {0xAB01, 0xAB06}, {0xAB09, 0xAB0E}, {0xAB11, 0xAB16},
{0xAB20, 0xAB26}, {0xAB28, 0xAB2E}, {0xAB30, 0xAB6B}, {0xAB70, 0xABED},
{0xABF0, 0xABF9}, {0xAC00, 0xD7A3}, {0xD7B0, 0xD7C6}, {0xD7CB, 0xD7FB},
{0xF900, 0xFA6D}, {0xFA70, 0xFAD9}, {0xFB00, 0xFB06}, {0xFB13, 0xFB17},
{0xFB1D, 0xFB36}, {0xFB38, 0xFB3C}, {0xFB46, 0xFBC2}, {0xFBD3, 0xFD8F},
{0xFD92, 0xFDC7}, {0xFDF0, 0xFE19}, {0xFE20, 0xFE52}, {0xFE54, 0xFE66},
{0xFE68, 0xFE6B}, {0xFE70, 0xFE74}, {0xFE76, 0xFEFC}, {0xFF01, 0xFFBE},
{0xFFC2, 0xFFC7}, {0xFFCA, 0xFFCF}, {0xFFD2, 0xFFD7}, {0xFFDA, 0xFFDC},
{0xFFE0, 0xFFE6}, {0xFFE8, 0xFFEE}
#if CHRBITS > 16
,{0x10000, 0x1000B}, {0x1000D, 0x10026}, {0x10028, 0x1003A}, {0x1003F, 0x1004D},
{0x10050, 0x1005D}, {0x10080, 0x100FA}, {0x10100, 0x10102}, {0x10107, 0x10133},
{0x10137, 0x1018E}, {0x10190, 0x1019C}, {0x101D0, 0x101FD}, {0x10280, 0x1029C},
{0x102A0, 0x102D0}, {0x102E0, 0x102FB}, {0x10300, 0x10323}, {0x1032D, 0x1034A},
{0x10350, 0x1037A}, {0x10380, 0x1039D}, {0x1039F, 0x103C3}, {0x103C8, 0x103D5},
{0x10400, 0x1049D}, {0x104A0, 0x104A9}, {0x104B0, 0x104D3}, {0x104D8, 0x104FB},
{0x10500, 0x10527}, {0x10530, 0x10563}, {0x1056F, 0x1057A}, {0x1057C, 0x1058A},
{0x1058C, 0x10592}, {0x10597, 0x105A1}, {0x105A3, 0x105B1}, {0x105B3, 0x105B9},
{0x10600, 0x10736}, {0x10740, 0x10755}, {0x10760, 0x10767}, {0x10780, 0x10785},
{0x10787, 0x107B0}, {0x107B2, 0x107BA}, {0x10800, 0x10805}, {0x1080A, 0x10835},
{0x1083F, 0x10855}, {0x10857, 0x1089E}, {0x108A7, 0x108AF}, {0x108E0, 0x108F2},
{0x108FB, 0x1091B}, {0x1091F, 0x10939}, {0x10980, 0x109B7}, {0x109BC, 0x109CF},
{0x109D2, 0x10A03}, {0x10A0C, 0x10A13}, {0x10A15, 0x10A17}, {0x10A19, 0x10A35},
{0x10A38, 0x10A3A}, {0x10A3F, 0x10A48}, {0x10A50, 0x10A58}, {0x10A60, 0x10A9F},
{0x10AC0, 0x10AE6}, {0x10AEB, 0x10AF6}, {0x10B00, 0x10B35}, {0x10B39, 0x10B55},
{0x10B58, 0x10B72}, {0x10B78, 0x10B91}, {0x10B99, 0x10B9C}, {0x10BA9, 0x10BAF},
{0x10C00, 0x10C48}, {0x10C80, 0x10CB2}, {0x10CC0, 0x10CF2}, {0x10CFA, 0x10D27},
{0x10D30, 0x10D39}, {0x10E60, 0x10E7E}, {0x10E80, 0x10EA9}, {0x10EAB, 0x10EAD},
{0x10EFD, 0x10F27}, {0x10F30, 0x10F59}, {0x10F70, 0x10F89}, {0x10FB0, 0x10FCB},
{0x10FE0, 0x10FF6}, {0x11000, 0x1104D}, {0x11052, 0x11075}, {0x1107F, 0x110BC},
{0x110BE, 0x110C2}, {0x110D0, 0x110E8}, {0x110F0, 0x110F9}, {0x11100, 0x11134},
{0x11136, 0x11147}, {0x11150, 0x11176}, {0x11180, 0x111DF}, {0x111E1, 0x111F4},
{0x11200, 0x11211}, {0x11213, 0x11241}, {0x11280, 0x11286}, {0x1128A, 0x1128D},
{0x1128F, 0x1129D}, {0x1129F, 0x112A9}, {0x112B0, 0x112EA}, {0x112F0, 0x112F9},
{0x11300, 0x11303}, {0x11305, 0x1130C}, {0x11313, 0x11328}, {0x1132A, 0x11330},
{0x11335, 0x11339}, {0x1133B, 0x11344}, {0x1134B, 0x1134D}, {0x1135D, 0x11363},
{0x11366, 0x1136C}, {0x11370, 0x11374}, {0x11400, 0x1145B}, {0x1145D, 0x11461},
{0x11480, 0x114C7}, {0x114D0, 0x114D9}, {0x11580, 0x115B5}, {0x115B8, 0x115DD},
{0x11600, 0x11644}, {0x11650, 0x11659}, {0x11660, 0x1166C}, {0x11680, 0x116B9},
{0x116C0, 0x116C9}, {0x11700, 0x1171A}, {0x1171D, 0x1172B}, {0x11730, 0x11746},
{0x11800, 0x1183B}, {0x118A0, 0x118F2}, {0x118FF, 0x11906}, {0x1190C, 0x11913},
{0x11918, 0x11935}, {0x1193B, 0x11946}, {0x11950, 0x11959}, {0x119A0, 0x119A7},
{0x119AA, 0x119D7}, {0x119DA, 0x119E4}, {0x11A00, 0x11A47}, {0x11A50, 0x11AA2},
{0x11AB0, 0x11AF8}, {0x11B00, 0x11B09}, {0x11C00, 0x11C08}, {0x11C0A, 0x11C36},
{0x11C38, 0x11C45}, {0x11C50, 0x11C6C}, {0x11C70, 0x11C8F}, {0x11C92, 0x11CA7},
{0x11CA9, 0x11CB6}, {0x11D00, 0x11D06}, {0x11D0B, 0x11D36}, {0x11D3F, 0x11D47},
{0x11D50, 0x11D59}, {0x11D60, 0x11D65}, {0x11D6A, 0x11D8E}, {0x11D93, 0x11D98},
{0x11DA0, 0x11DA9}, {0x11EE0, 0x11EF8}, {0x11F00, 0x11F10}, {0x11F12, 0x11F3A},
{0x11F3E, 0x11F59}, {0x11FC0, 0x11FF1}, {0x11FFF, 0x12399}, {0x12400, 0x1246E},
{0x12470, 0x12474}, {0x12480, 0x12543}, {0x12F90, 0x12FF2}, {0x13000, 0x1342F},
{0x13440, 0x13455}, {0x14400, 0x14646}, {0x16800, 0x16A38}, {0x16A40, 0x16A5E},
{0x16A60, 0x16A69}, {0x16A6E, 0x16ABE}, {0x16AC0, 0x16AC9}, {0x16AD0, 0x16AED},
{0x16AF0, 0x16AF5}, {0x16B00, 0x16B45}, {0x16B50, 0x16B59}, {0x16B5B, 0x16B61},
{0x16B63, 0x16B77}, {0x16B7D, 0x16B8F}, {0x16E40, 0x16E9A}, {0x16F00, 0x16F4A},
{0x16F4F, 0x16F87}, {0x16F8F, 0x16F9F}, {0x16FE0, 0x16FE4}, {0x17000, 0x187F7},
{0x18800, 0x18CD5}, {0x18D00, 0x18D08}, {0x1AFF0, 0x1AFF3}, {0x1AFF5, 0x1AFFB},
{0x1B000, 0x1B122}, {0x1B150, 0x1B152}, {0x1B164, 0x1B167}, {0x1B170, 0x1B2FB},
{0x1BC00, 0x1BC6A}, {0x1BC70, 0x1BC7C}, {0x1BC80, 0x1BC88}, {0x1BC90, 0x1BC99},
{0x1BC9C, 0x1BC9F}, {0x1CF00, 0x1CF2D}, {0x1CF30, 0x1CF46}, {0x1CF50, 0x1CFC3},
{0x1D000, 0x1D0F5}, {0x1D100, 0x1D126}, {0x1D129, 0x1D172}, {0x1D17B, 0x1D1EA},
{0x1D200, 0x1D245}, {0x1D2C0, 0x1D2D3}, {0x1D2E0, 0x1D2F3}, {0x1D300, 0x1D356},
{0x1D360, 0x1D378}, {0x1D400, 0x1D454}, {0x1D456, 0x1D49C}, {0x1D4A9, 0x1D4AC},
{0x1D4AE, 0x1D4B9}, {0x1D4BD, 0x1D4C3}, {0x1D4C5, 0x1D505}, {0x1D507, 0x1D50A},
{0x1D50D, 0x1D514}, {0x1D516, 0x1D51C}, {0x1D51E, 0x1D539}, {0x1D53B, 0x1D53E},
{0x1D540, 0x1D544}, {0x1D54A, 0x1D550}, {0x1D552, 0x1D6A5}, {0x1D6A8, 0x1D7CB},
{0x1D7CE, 0x1DA8B}, {0x1DA9B, 0x1DA9F}, {0x1DAA1, 0x1DAAF}, {0x1DF00, 0x1DF1E},
{0x1DF25, 0x1DF2A}, {0x1E000, 0x1E006}, {0x1E008, 0x1E018}, {0x1E01B, 0x1E021},
{0x1E026, 0x1E02A}, {0x1E030, 0x1E06D}, {0x1E100, 0x1E12C}, {0x1E130, 0x1E13D},
{0x1E140, 0x1E149}, {0x1E290, 0x1E2AE}, {0x1E2C0, 0x1E2F9}, {0x1E4D0, 0x1E4F9},
{0x1E7E0, 0x1E7E6}, {0x1E7E8, 0x1E7EB}, {0x1E7F0, 0x1E7FE}, {0x1E800, 0x1E8C4},
{0x1E8C7, 0x1E8D6}, {0x1E900, 0x1E94B}, {0x1E950, 0x1E959}, {0x1EC71, 0x1ECB4},
{0x1ED01, 0x1ED3D}, {0x1EE00, 0x1EE03}, {0x1EE05, 0x1EE1F}, {0x1EE29, 0x1EE32},
{0x1EE34, 0x1EE37}, {0x1EE4D, 0x1EE4F}, {0x1EE67, 0x1EE6A}, {0x1EE6C, 0x1EE72},
{0x1EE74, 0x1EE77}, {0x1EE79, 0x1EE7C}, {0x1EE80, 0x1EE89}, {0x1EE8B, 0x1EE9B},
{0x1EEA1, 0x1EEA3}, {0x1EEA5, 0x1EEA9}, {0x1EEAB, 0x1EEBB}, {0x1F000, 0x1F02B},
{0x1F030, 0x1F093}, {0x1F0A0, 0x1F0AE}, {0x1F0B1, 0x1F0BF}, {0x1F0C1, 0x1F0CF},
{0x1F0D1, 0x1F0F5}, {0x1F100, 0x1F1AD}, {0x1F1E6, 0x1F202}, {0x1F210, 0x1F23B},
{0x1F240, 0x1F248}, {0x1F260, 0x1F265}, {0x1F300, 0x1F6D7}, {0x1F6DC, 0x1F6EC},
{0x1F6F0, 0x1F6FC}, {0x1F700, 0x1F776}, {0x1F77B, 0x1F7D9}, {0x1F7E0, 0x1F7EB},
{0x1F800, 0x1F80B}, {0x1F810, 0x1F847}, {0x1F850, 0x1F859}, {0x1F860, 0x1F887},
{0x1F890, 0x1F8AD}, {0x1F900, 0x1FA53}, {0x1FA60, 0x1FA6D}, {0x1FA70, 0x1FA7C},
{0x1FA80, 0x1FA88}, {0x1FA90, 0x1FABD}, {0x1FABF, 0x1FAC5}, {0x1FACE, 0x1FADB},
{0x1FAE0, 0x1FAE8}, {0x1FAF0, 0x1FAF8}, {0x1FB00, 0x1FB92}, {0x1FB94, 0x1FBCA},
{0x1FBF0, 0x1FBF9}, {0x20000, 0x2A6DF}, {0x2A700, 0x2B739}, {0x2B740, 0x2B81D},
{0x2B820, 0x2CEA1}, {0x2CEB0, 0x2EBE0}, {0x2F800, 0x2FA1D}, {0x30000, 0x3134A},
{0x31350, 0x323AF}, {0xE0100, 0xE01EF}
#endif
};
#define NUM_GRAPH_RANGE (sizeof(graphRangeTable)/sizeof(crange))
static const chr graphCharTable[] = {
0x38C, 0x85E, 0x98F, 0x990, 0x9B2, 0x9C7, 0x9C8, 0x9D7, 0x9DC,
0x9DD, 0xA0F, 0xA10, 0xA32, 0xA33, 0xA35, 0xA36, 0xA38, 0xA39,
0xA3C, 0xA47, 0xA48, 0xA51, 0xA5E, 0xAB2, 0xAB3, 0xAD0, 0xB0F,
0xB10, 0xB32, 0xB33, 0xB47, 0xB48, 0xB5C, 0xB5D, 0xB82, 0xB83,
0xB99, 0xB9A, 0xB9C, 0xB9E, 0xB9F, 0xBA3, 0xBA4, 0xBD0, 0xBD7,
0xC55, 0xC56, 0xC5D, 0xCD5, 0xCD6, 0xCDD, 0xCDE, 0xDBD, 0xDCA,
0xDD6, 0xE81, 0xE82, 0xE84, 0xEA5, 0xEC6, 0x10C7, 0x10CD, 0x1258,
0x12C0, 0x1772, 0x1773, 0x1940, 0x1F59, 0x1F5B, 0x1F5D, 0x2070, 0x2071,
0x2D27, 0x2D2D, 0x2D6F, 0x2D70, 0xA7D0, 0xA7D1, 0xA7D3, 0xFB3E, 0xFB40,
0xFB41, 0xFB43, 0xFB44, 0xFDCF, 0xFFFC, 0xFFFD
#if CHRBITS > 16
,0x1003C, 0x1003D, 0x101A0, 0x10594, 0x10595, 0x105BB, 0x105BC, 0x10808, 0x10837,
0x10838, 0x1083C, 0x108F4, 0x108F5, 0x1093F, 0x10A05, 0x10A06, 0x10EB0, 0x10EB1,
0x11288, 0x1130F, 0x11310, 0x11332, 0x11333, 0x11347, 0x11348, 0x11350, 0x11357,
0x11909, 0x11915, 0x11916, 0x11937, 0x11938, 0x11D08, 0x11D09, 0x11D3A, 0x11D3C,
0x11D3D, 0x11D67, 0x11D68, 0x11D90, 0x11D91, 0x11FB0, 0x16FF0, 0x16FF1, 0x1AFFD,
0x1AFFE, 0x1B132, 0x1B155, 0x1D49E, 0x1D49F, 0x1D4A2, 0x1D4A5, 0x1D4A6, 0x1D4BB,
0x1D546, 0x1E023, 0x1E024, 0x1E08F, 0x1E14E, 0x1E14F, 0x1E2FF, 0x1E7ED, 0x1E7EE,
0x1E95E, 0x1E95F, 0x1EE21, 0x1EE22, 0x1EE24, 0x1EE27, 0x1EE39, 0x1EE3B, 0x1EE42,
0x1EE47, 0x1EE49, 0x1EE4B, 0x1EE51, 0x1EE52, 0x1EE54, 0x1EE57, 0x1EE59, 0x1EE5B,
0x1EE5D, 0x1EE5F, 0x1EE61, 0x1EE62, 0x1EE64, 0x1EE7E, 0x1EEF0, 0x1EEF1, 0x1F250,
0x1F251, 0x1F7F0, 0x1F8B0, 0x1F8B1
#endif
};
#define NUM_GRAPH_CHAR (sizeof(graphCharTable)/sizeof(chr))
/*
* End of auto-generated Unicode character ranges declarations.
|
| ︙ | ︙ |
Changes to generic/regc_nfa.c.
| ︙ | ︙ | |||
104 105 106 107 108 109 110 |
}
while ((s = nfa->free) != NULL) {
nfa->free = s->next;
destroystate(nfa, s);
}
nfa->slast = NULL;
| | | 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 |
}
while ((s = nfa->free) != NULL) {
nfa->free = s->next;
destroystate(nfa, s);
}
nfa->slast = NULL;
nfa->nstates = FREESTATE;
nfa->pre = NULL;
nfa->post = NULL;
FREE(nfa);
}
/*
- newstate - allocate an NFA state, with zero flag value
|
| ︙ | ︙ | |||
139 140 141 142 143 144 145 |
}
nfa->v->spaceused += sizeof(struct state);
s->oas.next = NULL;
s->free = NULL;
s->noas = 0;
}
| | | 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 |
}
nfa->v->spaceused += sizeof(struct state);
s->oas.next = NULL;
s->free = NULL;
s->noas = 0;
}
assert(nfa->nstates != FREESTATE);
s->no = nfa->nstates++;
s->flag = 0;
if (nfa->states == NULL) {
nfa->states = s;
}
s->nins = 0;
s->ins = NULL;
|
| ︙ | ︙ | |||
2490 2491 2492 2493 2494 2495 2496 |
struct nfa * nfa,
struct state * ssource,
struct state * sclone,
struct state * spredecessor,
struct arc * refarc,
char *curdonemap,
char *outerdonemap,
| | | 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 |
struct nfa * nfa,
struct state * ssource,
struct state * sclone,
struct state * spredecessor,
struct arc * refarc,
char *curdonemap,
char *outerdonemap,
size_t nstates)
{
char *donemap;
struct arc *a;
/* Since this is recursive, it could be driven to stack overflow */
if (STACK_TOO_DEEP(nfa->v->re)) {
NERR(REG_ETOOBIG);
|
| ︙ | ︙ | |||
2687 2688 2689 2690 2691 2692 2693 |
*/
static void
cleanup(
struct nfa *nfa)
{
struct state *s;
struct state *nexts;
| | | 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 |
*/
static void
cleanup(
struct nfa *nfa)
{
struct state *s;
struct state *nexts;
size_t n;
/*
* Clear out unreachable or dead-end states. Use pre to mark reachable,
* then post to mark can-reach-post.
*/
markreachable(nfa, nfa->pre, NULL, nfa->pre);
|
| ︙ | ︙ | |||
2843 2844 2845 2846 2847 2848 2849 |
cnfa->eos[0] = nfa->eos[0];
cnfa->eos[1] = nfa->eos[1];
cnfa->ncolors = maxcolor(nfa->cm) + 1;
cnfa->flags = 0;
ca = cnfa->arcs;
for (s = nfa->states; s != NULL; s = s->next) {
| | | 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 |
cnfa->eos[0] = nfa->eos[0];
cnfa->eos[1] = nfa->eos[1];
cnfa->ncolors = maxcolor(nfa->cm) + 1;
cnfa->flags = 0;
ca = cnfa->arcs;
for (s = nfa->states; s != NULL; s = s->next) {
assert(s->no < nstates);
cnfa->stflags[s->no] = 0;
cnfa->states[s->no] = ca;
first = ca;
for (a = s->outs; a != NULL; a = a->outchain) {
switch (a->type) {
case PLAIN:
ca->co = a->co;
|
| ︙ | ︙ | |||
2947 2948 2949 2950 2951 2952 2953 |
static void
dumpnfa(
struct nfa *nfa,
FILE *f)
{
#ifdef REG_DEBUG
struct state *s;
| | | | | | 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 |
static void
dumpnfa(
struct nfa *nfa,
FILE *f)
{
#ifdef REG_DEBUG
struct state *s;
size_t nstates = 0;
size_t narcs = 0;
fprintf(f, "pre %" TCL_Z_MODIFIER "u, post %" TCL_Z_MODIFIER "u", nfa->pre->no, nfa->post->no);
if (nfa->bos[0] != COLORLESS) {
fprintf(f, ", bos [%ld]", (long) nfa->bos[0]);
}
if (nfa->bos[1] != COLORLESS) {
fprintf(f, ", bol [%ld]", (long) nfa->bos[1]);
}
if (nfa->eos[0] != COLORLESS) {
fprintf(f, ", eos [%ld]", (long) nfa->eos[0]);
}
if (nfa->eos[1] != COLORLESS) {
fprintf(f, ", eol [%ld]", (long) nfa->eos[1]);
}
fprintf(f, "\n");
for (s = nfa->states; s != NULL; s = s->next) {
dumpstate(s, f);
nstates++;
narcs += s->nouts;
}
fprintf(f, "total of %" TCL_Z_MODIFIER "u states, %" TCL_Z_MODIFIER "u arcs\n", nstates, narcs);
if (nfa->parent == NULL) {
dumpcolors(nfa->cm, f);
}
fflush(f);
#else
(void)nfa;
(void)f;
|
| ︙ | ︙ | |||
2996 2997 2998 2999 3000 3001 3002 |
static void
dumpstate(
struct state *s,
FILE *f)
{
struct arc *a;
| | | | 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 |
static void
dumpstate(
struct state *s,
FILE *f)
{
struct arc *a;
fprintf(f, "%" TCL_Z_MODIFIER "u%s%c", s->no, (s->tmp != NULL) ? "T" : "",
(s->flag) ? s->flag : '.');
if (s->prev != NULL && s->prev->next != s) {
fprintf(f, "\tstate chain bad\n");
}
if (s->nouts == 0) {
fprintf(f, "\tno out arcs\n");
} else {
dumparcs(s, f);
}
fflush(f);
for (a = s->ins; a != NULL; a = a->inchain) {
if (a->to != s) {
fprintf(f, "\tlink from %" TCL_Z_MODIFIER "u to %" TCL_Z_MODIFIER "u on %" TCL_Z_MODIFIER "u's in-chain\n",
a->from->no, a->to->no, s->no);
}
}
}
/*
- dumparcs - dump out-arcs in human-readable form
|
| ︙ | ︙ | |||
3087 3088 3089 3090 3091 3092 3093 |
case EMPTY:
break;
default:
fprintf(f, "0x%x/0%lo", a->type, (long) a->co);
break;
}
if (a->from != s) {
| | | | 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 |
case EMPTY:
break;
default:
fprintf(f, "0x%x/0%lo", a->type, (long) a->co);
break;
}
if (a->from != s) {
fprintf(f, "?%" TCL_Z_MODIFIER "u?", a->from->no);
}
for (ab = &a->from->oas; ab != NULL; ab = ab->next) {
for (aa = &ab->a[0]; aa < &ab->a[ABSIZE]; aa++) {
if (aa == a) {
break; /* NOTE BREAK OUT */
}
}
if (aa < &ab->a[ABSIZE]) { /* propagate break */
break; /* NOTE BREAK OUT */
}
}
if (ab == NULL) {
fprintf(f, "?!?"); /* not in allocated space */
}
fprintf(f, "->");
if (a->to == NULL) {
fprintf(f, "NULL");
return;
}
fprintf(f, "%" TCL_Z_MODIFIER "u", a->to->no);
for (aa = a->to->ins; aa != NULL; aa = aa->inchain) {
if (aa == a) {
break; /* NOTE BREAK OUT */
}
}
if (aa == NULL) {
fprintf(f, "?!?"); /* missing from in-chain */
|
| ︙ | ︙ | |||
3133 3134 3135 3136 3137 3138 3139 |
*/
static void
dumpcnfa(
struct cnfa *cnfa,
FILE *f)
{
#ifdef REG_DEBUG
| | | | 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 |
*/
static void
dumpcnfa(
struct cnfa *cnfa,
FILE *f)
{
#ifdef REG_DEBUG
size_t st;
fprintf(f, "pre %" TCL_Z_MODIFIER "u, post %" TCL_Z_MODIFIER "u", cnfa->pre, cnfa->post);
if (cnfa->bos[0] != COLORLESS) {
fprintf(f, ", bos [%ld]", (long) cnfa->bos[0]);
}
if (cnfa->bos[1] != COLORLESS) {
fprintf(f, ", bol [%ld]", (long) cnfa->bos[1]);
}
if (cnfa->eos[0] != COLORLESS) {
|
| ︙ | ︙ | |||
3178 3179 3180 3181 3182 3183 3184 |
static void
dumpcstate(
int st,
struct cnfa *cnfa,
FILE *f)
{
struct carc *ca;
| | | | | 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 |
static void
dumpcstate(
int st,
struct cnfa *cnfa,
FILE *f)
{
struct carc *ca;
size_t pos;
fprintf(f, "%d%s", st, (cnfa->stflags[st] & CNFA_NOPROGRESS) ? ":" : ".");
pos = 1;
for (ca = cnfa->states[st]; ca->co != COLORLESS; ca++) {
if (ca->co < cnfa->ncolors) {
fprintf(f, "\t[%d]->%" TCL_Z_MODIFIER "u", ca->co, ca->to);
} else {
fprintf(f, "\t:%d:->%" TCL_Z_MODIFIER "u", ca->co - cnfa->ncolors, ca->to);
}
if (pos == 5) {
fprintf(f, "\n");
pos = 1;
} else {
pos++;
}
|
| ︙ | ︙ |
Changes to generic/regcomp.c.
| ︙ | ︙ | |||
152 153 154 155 156 157 158 | struct state *, struct arc **); static int isconstraintarc(struct arc *); static int hasconstraintout(struct state *); static void fixconstraintloops(struct nfa *, FILE *); static int findconstraintloop(struct nfa *, struct state *); static void breakconstraintloop(struct nfa *, struct state *); static void clonesuccessorstates(struct nfa *, struct state *, struct state *, | | | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 | struct state *, struct arc **); static int isconstraintarc(struct arc *); static int hasconstraintout(struct state *); static void fixconstraintloops(struct nfa *, FILE *); static int findconstraintloop(struct nfa *, struct state *); static void breakconstraintloop(struct nfa *, struct state *); static void clonesuccessorstates(struct nfa *, struct state *, struct state *, struct state *, struct arc *, char *, char *, size_t); static void cleanup(struct nfa *); static void markreachable(struct nfa *, struct state *, struct state *, struct state *); static void markcanreach(struct nfa *, struct state *, struct state *, struct state *); static long analyze(struct nfa *); static void compact(struct nfa *, struct cnfa *); static void carcsort(struct carc *, size_t); static int carc_cmp(const void *, const void *); |
| ︙ | ︙ | |||
175 176 177 178 179 180 181 | #ifdef REG_DEBUG static void dumpcstate(int, struct cnfa *, FILE *); #endif /* === regc_cvec.c === */ static struct cvec *clearcvec(struct cvec *); static void addchr(struct cvec *, pchr); static void addrange(struct cvec *, pchr, pchr); | | | | 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 | #ifdef REG_DEBUG static void dumpcstate(int, struct cnfa *, FILE *); #endif /* === regc_cvec.c === */ static struct cvec *clearcvec(struct cvec *); static void addchr(struct cvec *, pchr); static void addrange(struct cvec *, pchr, pchr); static struct cvec *newcvec(size_t, size_t); static struct cvec *getcvec(struct vars *, size_t, size_t); static void freecvec(struct cvec *); /* === regc_locale.c === */ static celt element(struct vars *, const chr *, const chr *); static struct cvec *range(struct vars *, celt, celt, int); static int before(celt, celt); static struct cvec *eclass(struct vars *, celt, int); static struct cvec *cclass(struct vars *, const chr *, const chr *, int); |
| ︙ | ︙ | |||
406 407 408 409 410 411 412 |
*/
re->re_info |= nfatree(v, v->tree, debug);
CNOERR();
assert(v->nlacons == 0 || v->lacons != NULL);
for (i = 1; i < v->nlacons; i++) {
if (debug != NULL) {
| | | 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 |
*/
re->re_info |= nfatree(v, v->tree, debug);
CNOERR();
assert(v->nlacons == 0 || v->lacons != NULL);
for (i = 1; i < v->nlacons; i++) {
if (debug != NULL) {
fprintf(debug, "\n\n\n========= LA%" TCL_Z_MODIFIER "u ==========\n", i);
}
nfanode(v, &v->lacons[i], debug);
}
CNOERR();
if (v->tree->flags&SHORTER) {
NOTE(REG_USHORTEST);
}
|
| ︙ | ︙ | |||
2043 2044 2045 2046 2047 2048 2049 |
static void
dump(
regex_t *re,
FILE *f)
{
#ifdef REG_DEBUG
struct guts *g;
| | | | | 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 |
static void
dump(
regex_t *re,
FILE *f)
{
#ifdef REG_DEBUG
struct guts *g;
size_t i;
if (re->re_magic != REMAGIC) {
fprintf(f, "bad magic number (0x%x not 0x%x)\n",
re->re_magic, REMAGIC);
}
if (re->re_guts == NULL) {
fprintf(f, "NULL guts!!!\n");
return;
}
g = (struct guts *) re->re_guts;
if (g->magic != GUTSMAGIC) {
fprintf(f, "bad guts magic number (0x%x not 0x%x)\n",
g->magic, GUTSMAGIC);
}
fprintf(f, "\n\n\n========= DUMP ==========\n");
fprintf(f, "nsub %" TCL_Z_MODIFIER "u, info 0%lo, ntree %" TCL_Z_MODIFIER "u\n",
re->re_nsub, re->re_info, g->ntree);
dumpcolors(&g->cmap, f);
if (!NULLCNFA(g->search)) {
fprintf(f, "\nsearch:\n");
dumpcnfa(&g->search, f);
}
for (i = 1; i < g->nlacons; i++) {
fprintf(f, "\nla%" TCL_Z_MODIFIER "u (%s):\n", i,
(g->lacons[i].subno) ? "positive" : "negative");
dumpcnfa(&g->lacons[i].cnfa, f);
}
fprintf(f, "\n");
dumpst(g->tree, f, 0);
#else
(void)re;
|
| ︙ | ︙ | |||
2141 2142 2143 2144 2145 2146 2147 |
fprintf(f, " {%d,", t->min);
if (t->max != DUPINF) {
fprintf(f, "%d", t->max);
}
fprintf(f, "}");
}
if (nfapresent) {
| | | 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 |
fprintf(f, " {%d,", t->min);
if (t->max != DUPINF) {
fprintf(f, "%d", t->max);
}
fprintf(f, "}");
}
if (nfapresent) {
fprintf(f, " %" TCL_Z_MODIFIER "u-%" TCL_Z_MODIFIER "u", t->begin->no, t->end->no);
}
if (t->left != NULL) {
fprintf(f, " L:%s", stid(t->left, idbuf, sizeof(idbuf)));
}
if (t->right != NULL) {
fprintf(f, " R:%s", stid(t->right, idbuf, sizeof(idbuf)));
}
|
| ︙ | ︙ |
Changes to generic/rege_dfa.c.
| ︙ | ︙ | |||
43 44 45 46 47 48 49 |
int *const hitstopp) /* record whether hit v->stop, if non-NULL */
{
chr *cp;
chr *realstop = (stop == v->stop) ? stop : stop + 1;
color co;
struct sset *css, *ss;
chr *post;
| | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
int *const hitstopp) /* record whether hit v->stop, if non-NULL */
{
chr *cp;
chr *realstop = (stop == v->stop) ? stop : stop + 1;
color co;
struct sset *css, *ss;
chr *post;
size_t i;
struct colormap *cm = d->cm;
/*
* Initialize.
*/
css = initialize(v, d, start);
|
| ︙ | ︙ | |||
288 289 290 291 292 293 294 |
static chr * /* endpoint, or NULL */
lastCold(
struct vars *const v,
struct dfa *const d)
{
struct sset *ss;
chr *nopr = d->lastnopr;
| | | 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 |
static chr * /* endpoint, or NULL */
lastCold(
struct vars *const v,
struct dfa *const d)
{
struct sset *ss;
chr *nopr = d->lastnopr;
size_t i;
if (nopr == NULL) {
nopr = v->start;
}
for (ss = d->ssets, i = d->nssused; i > 0; ss++, i--) {
if ((ss->flags&NOPROGRESS) && nopr < ss->lastseen) {
nopr = ss->lastseen;
|
| ︙ | ︙ | |||
315 316 317 318 319 320 321 |
struct vars *const v,
struct cnfa *const cnfa,
struct colormap *const cm,
struct smalldfa *sml) /* preallocated space, may be NULL */
{
struct dfa *d;
size_t nss = cnfa->nstates * 2;
| | | 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 |
struct vars *const v,
struct cnfa *const cnfa,
struct colormap *const cm,
struct smalldfa *sml) /* preallocated space, may be NULL */
{
struct dfa *d;
size_t nss = cnfa->nstates * 2;
size_t wordsper = (cnfa->nstates + UBITS - 1) / UBITS;
struct smalldfa *smallwas = sml;
assert(cnfa != NULL && cnfa->nstates != 0);
if (nss <= FEWSTATES && cnfa->ncolors <= FEWCOLORS) {
assert(wordsper == 1);
if (sml == NULL) {
|
| ︙ | ︙ | |||
438 439 440 441 442 443 444 |
static struct sset *
initialize(
struct vars *const v, /* used only for debug flags */
struct dfa *const d,
chr *const start)
{
struct sset *ss;
| | | 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 |
static struct sset *
initialize(
struct vars *const v, /* used only for debug flags */
struct dfa *const d,
chr *const start)
{
struct sset *ss;
size_t i;
/*
* Is previous one still there?
*/
if (d->nssused > 0 && (d->ssets[0].flags&STARTER)) {
ss = &d->ssets[0];
|
| ︙ | ︙ | |||
488 489 490 491 492 493 494 |
chr *const cp, /* next chr */
chr *const start) /* where the attempt got started */
{
struct cnfa *cnfa = d->cnfa;
unsigned h;
struct carc *ca;
struct sset *p;
| > | | 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 |
chr *const cp, /* next chr */
chr *const start) /* where the attempt got started */
{
struct cnfa *cnfa = d->cnfa;
unsigned h;
struct carc *ca;
struct sset *p;
size_t i;
int isPost, noProgress, gotState, doLAConstraints, sawLAConstraints;
/*
* For convenience, we can be called even if it might not be a miss.
*/
if (css->outs[co] != NULL) {
FDEBUG(("hit\n"));
|
| ︙ | ︙ | |||
522 523 524 525 526 527 528 |
gotState = 1;
if (ca->to == cnfa->post) {
isPost = 1;
}
if (!(cnfa->stflags[ca->to] & CNFA_NOPROGRESS)) {
noProgress = 0;
}
| | | 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 |
gotState = 1;
if (ca->to == cnfa->post) {
isPost = 1;
}
if (!(cnfa->stflags[ca->to] & CNFA_NOPROGRESS)) {
noProgress = 0;
}
FDEBUG(("%" TCL_Z_MODIFIER "u -> %" TCL_Z_MODIFIER "u\n", i, ca->to));
}
}
}
}
doLAConstraints = (gotState ? (cnfa->flags&HASLACONS) : 0);
sawLAConstraints = 0;
while (doLAConstraints) { /* transitive closure */
|
| ︙ | ︙ | |||
552 553 554 555 556 557 558 |
doLAConstraints = 1;
if (ca->to == cnfa->post) {
isPost = 1;
}
if (!(cnfa->stflags[ca->to] & CNFA_NOPROGRESS)) {
noProgress = 0;
}
| | | 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 |
doLAConstraints = 1;
if (ca->to == cnfa->post) {
isPost = 1;
}
if (!(cnfa->stflags[ca->to] & CNFA_NOPROGRESS)) {
noProgress = 0;
}
FDEBUG(("%" TCL_Z_MODIFIER "u :> %" TCL_Z_MODIFIER"u\n", i, ca->to));
}
}
}
}
if (!gotState) {
return NULL;
}
|
| ︙ | ︙ | |||
611 612 613 614 615 616 617 |
static int /* predicate: constraint satisfied? */
checkLAConstraint(
struct vars *const v,
struct cnfa *const pcnfa, /* parent cnfa */
chr *const cp,
const pcolor co) /* "color" of the lookahead constraint */
{
| | | | | 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 |
static int /* predicate: constraint satisfied? */
checkLAConstraint(
struct vars *const v,
struct cnfa *const pcnfa, /* parent cnfa */
chr *const cp,
const pcolor co) /* "color" of the lookahead constraint */
{
size_t n;
struct subre *sub;
struct dfa *d;
struct smalldfa sd;
chr *end;
n = co - pcnfa->ncolors;
assert(n < v->g->nlacons && v->g->lacons != NULL);
FDEBUG(("=== testing lacon %" TCL_Z_MODIFIER "u\n", n));
sub = &v->g->lacons[n];
d = newDFA(v, &sub->cnfa, &v->g->cmap, &sd);
if (d == NULL) {
ERR(REG_ESPACE);
return 0;
}
end = longest(v, d, cp, v->stop, NULL);
freeDFA(d);
FDEBUG(("=== lacon %" TCL_Z_MODIFIER "u match %d\n", n, (end != NULL)));
return (sub->subno) ? (end != NULL) : (end == NULL);
}
/*
- getVacantSS - get a vacant state set
* This routine clears out the inarcs and outarcs, but does not otherwise
* clear the innards of the state set -- that's up to the caller.
|
| ︙ | ︙ | |||
734 735 736 737 738 739 740 |
chr *ancient;
/*
* Shortcut for cases where cache isn't full.
*/
if (d->nssused < d->nssets) {
| | | | | | | | | | | 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 |
chr *ancient;
/*
* Shortcut for cases where cache isn't full.
*/
if (d->nssused < d->nssets) {
size_t j = d->nssused;
d->nssused++;
ss = &d->ssets[j];
FDEBUG(("new c%" TCL_Z_MODIFIER "u\n", j));
/*
* Set up innards.
*/
ss->states = &d->statesarea[j * d->wordsper];
ss->flags = 0;
ss->ins.ss = NULL;
ss->ins.co = WHITE; /* give it some value */
ss->outs = &d->outsarea[j * d->ncolors];
ss->inchain = &d->incarea[j * d->ncolors];
for (i = 0; i < d->ncolors; i++) {
ss->outs[i] = NULL;
ss->inchain[i].ss = NULL;
}
return ss;
}
/*
* Look for oldest, or old enough anyway.
*/
if ((size_t)(cp - start) > d->nssets*2/3) { /* oldest 33% are expendable */
ancient = cp - d->nssets*2/3;
} else {
ancient = start;
}
for (ss = d->search, end = &d->ssets[d->nssets]; ss < end; ss++) {
if ((ss->lastseen == NULL || ss->lastseen < ancient)
&& !(ss->flags&LOCKED)) {
d->search = ss + 1;
FDEBUG(("replacing c%" TCL_Z_MODIFIER "u\n", (size_t)(ss - d->ssets)));
return ss;
}
}
for (ss = d->ssets, end = d->search; ss < end; ss++) {
if ((ss->lastseen == NULL || ss->lastseen < ancient)
&& !(ss->flags&LOCKED)) {
d->search = ss + 1;
FDEBUG(("replacing c%" TCL_Z_MODIFIER "u\n", (size_t)(ss - d->ssets)));
return ss;
}
}
/*
* Nobody's old enough?!? -- something's really wrong.
*/
|
| ︙ | ︙ |
Changes to generic/regexec.c.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 |
struct arcp ins; /* chain of inarcs pointing here */
chr *lastseen; /* last entered on arrival here */
struct sset **outs; /* outarc vector indexed by color */
struct arcp *inchain; /* chain-pointer vector for outarcs */
};
struct dfa {
| | | | > | < | 53 54 55 56 57 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 |
struct arcp ins; /* chain of inarcs pointing here */
chr *lastseen; /* last entered on arrival here */
struct sset **outs; /* outarc vector indexed by color */
struct arcp *inchain; /* chain-pointer vector for outarcs */
};
struct dfa {
size_t nssets; /* size of cache */
size_t nssused; /* how many entries occupied yet */
size_t nstates; /* number of states */
size_t wordsper; /* length of state-set bitvectors */
int ncolors; /* length of outarc and inchain vectors */
int cptsmalloced; /* were the areas individually malloced? */
struct sset *ssets; /* state-set cache */
unsigned *statesarea; /* bitvector storage */
unsigned *work; /* pointer to work area within statesarea */
struct sset **outsarea; /* outarc-vector storage */
struct arcp *incarea; /* inchain storage */
struct cnfa *cnfa;
struct colormap *cm;
chr *lastpost; /* location of last cache-flushed success */
chr *lastnopr; /* location of last cache-flushed NOPROGRESS */
struct sset *search; /* replacement-search-pointer memory */
char *mallocarea; /* self, or malloced area, or NULL */
};
#define WORK 1 /* number of work bitvectors needed */
/*
* Setup for non-malloc allocation for small cases.
|
| ︙ | ︙ | |||
112 113 114 115 116 117 118 |
};
#define VISERR(vv) ((vv)->err != 0) /* have we seen an error yet? */
#define ISERR() VISERR(v)
#define VERR(vv,e) ((vv)->err = ((vv)->err ? (vv)->err : (e)))
#define ERR(e) VERR(v, e) /* record an error */
#define NOERR() {if (ISERR()) return v->err;} /* if error seen, return it */
#define OFF(p) ((p) - v->start)
| | | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 |
};
#define VISERR(vv) ((vv)->err != 0) /* have we seen an error yet? */
#define ISERR() VISERR(v)
#define VERR(vv,e) ((vv)->err = ((vv)->err ? (vv)->err : (e)))
#define ERR(e) VERR(v, e) /* record an error */
#define NOERR() {if (ISERR()) return v->err;} /* if error seen, return it */
#define OFF(p) ((p) - v->start)
#define LOFF(p) ((size_t)OFF(p))
/*
* forward declarations
*/
/* =====^!^===== begin forwards =====^!^===== */
/* automatically gathered by fwd; do not hand-edit */
/* === regexec.c === */
|
| ︙ | ︙ | |||
228 229 230 231 232 233 234 |
}
v->details = details;
v->start = (chr *)string;
v->stop = (chr *)string + len;
v->err = 0;
assert(v->g->ntree >= 0);
n = v->g->ntree;
| | | > | > | 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 |
}
v->details = details;
v->start = (chr *)string;
v->stop = (chr *)string + len;
v->err = 0;
assert(v->g->ntree >= 0);
n = v->g->ntree;
if (n <= LOCALDFAS) {
v->subdfas = subdfas;
} else {
v->subdfas = (struct dfa **) MALLOC(n * sizeof(struct dfa *));
}
if (v->subdfas == NULL) {
if (v->pmatch != pmatch && v->pmatch != mat) {
FREE(v->pmatch);
}
FreeVars(v);
return REG_ESPACE;
}
for (i = 0; i < n; i++)
v->subdfas[i] = NULL;
/*
|
| ︙ | ︙ | |||
271 272 273 274 275 276 277 |
*/
if (v->pmatch != pmatch && v->pmatch != mat) {
FREE(v->pmatch);
}
n = v->g->ntree;
for (i = 0; i < n; i++) {
| | | > | > | > | 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 |
*/
if (v->pmatch != pmatch && v->pmatch != mat) {
FREE(v->pmatch);
}
n = v->g->ntree;
for (i = 0; i < n; i++) {
if (v->subdfas[i] != NULL) {
freeDFA(v->subdfas[i]);
}
}
if (v->subdfas != subdfas) {
FREE(v->subdfas);
}
FreeVars(v);
return st;
}
/*
- getsubdfa - create or re-fetch the DFA for a subre node
* We only need to create the DFA once per overall regex execution.
* The DFA will be freed by the cleanup step in exec().
*/
static struct dfa *
getsubdfa(struct vars * v,
struct subre * t)
{
if (v->subdfas[t->id] == NULL) {
v->subdfas[t->id] = newDFA(v, &t->cnfa, &v->g->cmap, NULL);
if (ISERR()) {
return NULL;
}
}
return v->subdfas[t->id];
}
/*
- simpleFind - find a match for the main NFA (no-complications case)
^ static int simpleFind(struct vars *, struct cnfa *, struct colormap *);
|
| ︙ | ︙ | |||
322 323 324 325 326 327 328 |
/*
* First, a shot with the search RE.
*/
s = newDFA(v, &v->g->search, cm, &v->dfa1);
assert(!(ISERR() && s != NULL));
NOERR();
| | | 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 |
/*
* First, a shot with the search RE.
*/
s = newDFA(v, &v->g->search, cm, &v->dfa1);
assert(!(ISERR() && s != NULL));
NOERR();
MDEBUG(("\nsearch at %" TCL_Z_MODIFIER "u\n", LOFF(v->start)));
cold = NULL;
close = shortest(v, s, v->start, v->start, v->stop, &cold, NULL);
freeDFA(s);
NOERR();
if (v->g->cflags®_EXPECT) {
assert(v->details != NULL);
if (cold != NULL) {
|
| ︙ | ︙ | |||
350 351 352 353 354 355 356 |
/*
* Find starting point and match.
*/
assert(cold != NULL);
open = cold;
cold = NULL;
| | | | 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 |
/*
* Find starting point and match.
*/
assert(cold != NULL);
open = cold;
cold = NULL;
MDEBUG(("between %" TCL_Z_MODIFIER "u and %" TCL_Z_MODIFIER "u\n", LOFF(open), LOFF(close)));
d = newDFA(v, cnfa, cm, &v->dfa1);
assert(!(ISERR() && d != NULL));
NOERR();
for (begin = open; begin <= close; begin++) {
MDEBUG(("\nfind trying at %" TCL_Z_MODIFIER "u\n", LOFF(begin)));
if (shorter) {
end = shortest(v, d, begin, begin, v->stop, NULL, &hitend);
} else {
end = longest(v, d, begin, v->stop, &hitend);
}
if (ISERR()) {
freeDFA(d);
|
| ︙ | ︙ | |||
466 467 468 469 470 471 472 |
int er, hitend;
int shorter = v->g->tree->flags&SHORTER;
assert(d != NULL && s != NULL);
cold = NULL;
close = v->start;
do {
| | | | | | 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 |
int er, hitend;
int shorter = v->g->tree->flags&SHORTER;
assert(d != NULL && s != NULL);
cold = NULL;
close = v->start;
do {
MDEBUG(("\ncsearch at %" TCL_Z_MODIFIER "u\n", LOFF(close)));
close = shortest(v, s, close, close, v->stop, &cold, NULL);
if (close == NULL) {
break; /* NOTE BREAK */
}
assert(cold != NULL);
open = cold;
cold = NULL;
MDEBUG(("cbetween %" TCL_Z_MODIFIER "u and %" TCL_Z_MODIFIER "u\n", LOFF(open), LOFF(close)));
for (begin = open; begin <= close; begin++) {
MDEBUG(("\ncomplicatedFind trying at %" TCL_Z_MODIFIER "u\n", LOFF(begin)));
estart = begin;
estop = v->stop;
for (;;) {
if (shorter) {
end = shortest(v, d, begin, estart, estop, NULL, &hitend);
} else {
end = longest(v, d, begin, estop, &hitend);
}
if (hitend && cold == NULL) {
cold = begin;
}
if (end == NULL) {
break; /* NOTE BREAK OUT */
}
MDEBUG(("tentative end %" TCL_Z_MODIFIER "u\n", LOFF(end)));
zapallsubs(v->pmatch, v->nmatch);
er = cdissect(v, v->g->tree, begin, end);
if (er == REG_OKAY) {
if (v->nmatch > 0) {
v->pmatch[0].rm_so = OFF(begin);
v->pmatch[0].rm_eo = OFF(end);
}
|
| ︙ | ︙ | |||
541 542 543 544 545 546 547 |
zapallsubs(
regmatch_t *const p,
const size_t n)
{
size_t i;
for (i = n-1; i > 0; i--) {
| | | | | | | | 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 |
zapallsubs(
regmatch_t *const p,
const size_t n)
{
size_t i;
for (i = n-1; i > 0; i--) {
p[i].rm_so = FREESTATE;
p[i].rm_eo = FREESTATE;
}
}
/*
- zaptreesubs - initialize subexpressions within subtree to "no match"
^ static void zaptreesubs(struct vars *, struct subre *);
*/
static void
zaptreesubs(
struct vars *const v,
struct subre *const t)
{
if (t->op == '(') {
size_t n = t->subno;
assert(n > 0);
if (n < v->nmatch) {
v->pmatch[n].rm_so = FREESTATE;
v->pmatch[n].rm_eo = FREESTATE;
}
}
if (t->left != NULL) {
zaptreesubs(v, t->left);
}
if (t->right != NULL) {
|
| ︙ | ︙ | |||
619 620 621 622 623 624 625 |
struct subre *t,
chr *begin, /* beginning of relevant substring */
chr *end) /* end of same */
{
int er;
assert(t != NULL);
| | | | > | | > | 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 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 |
struct subre *t,
chr *begin, /* beginning of relevant substring */
chr *end) /* end of same */
{
int er;
assert(t != NULL);
MDEBUG(("cdissect %" TCL_Z_MODIFIER "u-%" TCL_Z_MODIFIER "u %c\n", LOFF(begin), LOFF(end), t->op));
switch (t->op) {
case '=': /* terminal node */
assert(t->left == NULL && t->right == NULL);
er = REG_OKAY; /* no action, parent did the work */
break;
case 'b': /* back reference */
assert(t->left == NULL && t->right == NULL);
er = cbrdissect(v, t, begin, end);
break;
case '.': /* concatenation */
assert(t->left != NULL && t->right != NULL);
if (t->left->flags & SHORTER) {/* reverse scan */
er = crevcondissect(v, t, begin, end);
} else {
er = ccondissect(v, t, begin, end);
}
break;
case '|': /* alternation */
assert(t->left != NULL);
er = caltdissect(v, t, begin, end);
break;
case '*': /* iteration */
assert(t->left != NULL);
if (t->left->flags & SHORTER) {/* reverse scan */
er = creviterdissect(v, t, begin, end);
} else {
er = citerdissect(v, t, begin, end);
}
break;
case '(': /* capturing */
assert(t->left != NULL && t->right == NULL);
assert(t->subno > 0);
er = cdissect(v, t->left, begin, end);
if (er == REG_OKAY) {
subset(v, t, begin, end);
|
| ︙ | ︙ | |||
704 705 706 707 708 709 710 |
/*
* Pick a tentative midpoint.
*/
mid = longest(v, d, begin, end, (int *) NULL);
if (mid == NULL) {
return REG_NOMATCH;
}
| | | 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 |
/*
* Pick a tentative midpoint.
*/
mid = longest(v, d, begin, end, (int *) NULL);
if (mid == NULL) {
return REG_NOMATCH;
}
MDEBUG(("tentative midpoint %" TCL_Z_MODIFIER "u\n", LOFF(mid)));
/*
* Iterate until satisfaction or failure.
*/
for (;;) {
/*
|
| ︙ | ︙ | |||
755 756 757 758 759 760 761 |
/*
* Failed to find a new one.
*/
MDEBUG(("%d failed midpoint\n", t->id));
return REG_NOMATCH;
}
| | | 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 |
/*
* Failed to find a new one.
*/
MDEBUG(("%d failed midpoint\n", t->id));
return REG_NOMATCH;
}
MDEBUG(("%d: new midpoint %" TCL_Z_MODIFIER "u\n", t->id, LOFF(mid)));
zaptreesubs(v, t->left);
zaptreesubs(v, t->right);
}
}
/*
- crevcondissect - dissect match for concatenation node, shortest-first
|
| ︙ | ︙ | |||
795 796 797 798 799 800 801 |
* Pick a tentative midpoint.
*/
mid = shortest(v, d, begin, begin, end, (chr **) NULL, (int *) NULL);
if (mid == NULL) {
return REG_NOMATCH;
}
| | | 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 |
* Pick a tentative midpoint.
*/
mid = shortest(v, d, begin, begin, end, (chr **) NULL, (int *) NULL);
if (mid == NULL) {
return REG_NOMATCH;
}
MDEBUG(("tentative midpoint %" TCL_Z_MODIFIER "u\n", LOFF(mid)));
/*
* Iterate until satisfaction or failure.
*/
for (;;) {
/*
|
| ︙ | ︙ | |||
846 847 848 849 850 851 852 |
/*
* Failed to find a new one.
*/
MDEBUG(("%d failed midpoint\n", t->id));
return REG_NOMATCH;
}
| | | 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 |
/*
* Failed to find a new one.
*/
MDEBUG(("%d failed midpoint\n", t->id));
return REG_NOMATCH;
}
MDEBUG(("%d: new midpoint %" TCL_Z_MODIFIER "u\n", t->id, LOFF(mid)));
zaptreesubs(v, t->left);
zaptreesubs(v, t->right);
}
}
/*
- cbrdissect - dissect match for backref node
|
| ︙ | ︙ | |||
878 879 880 881 882 883 884 |
assert(t->op == 'b');
assert(n >= 0);
assert((size_t)n < v->nmatch);
MDEBUG(("cbackref n%d %d{%d-%d}\n", t->id, n, min, max));
/* get the backreferenced string */
| | | 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 |
assert(t->op == 'b');
assert(n >= 0);
assert((size_t)n < v->nmatch);
MDEBUG(("cbackref n%d %d{%d-%d}\n", t->id, n, min, max));
/* get the backreferenced string */
if (v->pmatch[n].rm_so == FREESTATE) {
return REG_NOMATCH;
}
brstring = v->start + v->pmatch[n].rm_so;
brlen = v->pmatch[n].rm_eo - v->pmatch[n].rm_so;
/* special cases for zero-length strings */
if (brlen == 0) {
|
| ︙ | ︙ | |||
912 913 914 915 916 917 918 |
/*
* check target length to see if it could possibly be an allowed number of
* repetitions of brstring
*/
assert(end > begin);
tlen = end - begin;
| | > | > | > | 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 |
/*
* check target length to see if it could possibly be an allowed number of
* repetitions of brstring
*/
assert(end > begin);
tlen = end - begin;
if (tlen % brlen != 0) {
return REG_NOMATCH;
}
numreps = tlen / brlen;
if (numreps < (size_t)min || (numreps > (size_t)max && max != DUPINF)) {
return REG_NOMATCH;
}
/* okay, compare the actual string contents */
p = begin;
while (numreps-- > 0) {
if ((*v->g->compare) (brstring, p, brlen) != 0) {
return REG_NOMATCH;
}
p += brlen;
}
MDEBUG(("cbackref matched\n"));
return REG_OKAY;
}
|
| ︙ | ︙ | |||
999 1000 1001 1002 1003 1004 1005 |
/*
* If zero matches are allowed, and target string is empty, just declare
* victory. OTOH, if target string isn't empty, zero matches can't work
* so we pretend the min is 1.
*/
min_matches = t->min;
if (min_matches <= 0) {
| | > | > | 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 1035 1036 1037 1038 1039 1040 1041 |
/*
* If zero matches are allowed, and target string is empty, just declare
* victory. OTOH, if target string isn't empty, zero matches can't work
* so we pretend the min is 1.
*/
min_matches = t->min;
if (min_matches <= 0) {
if (begin == end) {
return REG_OKAY;
}
min_matches = 1;
}
/*
* We need workspace to track the endpoints of each sub-match. Normally
* we consider only nonzero-length sub-matches, so there can be at most
* end-begin of them. However, if min is larger than that, we will also
* consider zero-length sub-matches in order to find enough matches.
*
* For convenience, endpts[0] contains the "begin" pointer and we store
* sub-match endpoints in endpts[1..max_matches].
*/
max_matches = end - begin;
if (max_matches > (size_t)t->max && t->max != DUPINF) {
max_matches = t->max;
}
if (max_matches < (size_t)min_matches)
max_matches = min_matches;
endpts = (chr **) MALLOC((max_matches + 1) * sizeof(chr *));
if (endpts == NULL)
return REG_ESPACE;
endpts[0] = begin;
|
| ︙ | ︙ | |||
1054 1055 1056 1057 1058 1059 1060 |
/* try to find an endpoint for the k'th sub-match */
endpts[k] = longest(v, d, endpts[k - 1], limit, (int *) NULL);
if (endpts[k] == NULL) {
/* no match possible, so see if we can shorten previous one */
k--;
goto backtrack;
}
| | | > | 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 |
/* try to find an endpoint for the k'th sub-match */
endpts[k] = longest(v, d, endpts[k - 1], limit, (int *) NULL);
if (endpts[k] == NULL) {
/* no match possible, so see if we can shorten previous one */
k--;
goto backtrack;
}
MDEBUG(("%d: working endpoint %d: %" TCL_Z_MODIFIER "u\n",
t->id, k, LOFF(endpts[k])));
/* k'th sub-match can no longer be considered verified */
if (nverified >= k) {
nverified = k - 1;
}
if (endpts[k] != end) {
/* haven't reached end yet, try another iteration if allowed */
if ((size_t)k >= max_matches) {
/* must try to shorten some previous match */
k--;
goto backtrack;
|
| ︙ | ︙ | |||
1085 1086 1087 1088 1089 1090 1091 | /* * We've identified a way to divide the string into k sub-matches * that works so far as the child DFA can tell. If k is an allowed * number of matches, start the slow part: recurse to verify each * sub-match. We always have k <= max_matches, needn't check that. */ | | > | > | 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 |
/*
* We've identified a way to divide the string into k sub-matches
* that works so far as the child DFA can tell. If k is an allowed
* number of matches, start the slow part: recurse to verify each
* sub-match. We always have k <= max_matches, needn't check that.
*/
if (k < min_matches) {
goto backtrack;
}
MDEBUG(("%d: verifying %d..%d\n", t->id, nverified + 1, k));
for (i = nverified + 1; i <= k; i++) {
zaptreesubs(v, t->left);
er = cdissect(v, t->left, endpts[i - 1], endpts[i]);
if (er == REG_OKAY) {
nverified = i;
continue;
}
if (er == REG_NOMATCH) {
break;
}
/* oops, something failed */
FREE(endpts);
return er;
}
if (i > k) {
/* satisfaction */
|
| ︙ | ︙ | |||
1172 1173 1174 1175 1176 1177 1178 |
/*
* If zero matches are allowed, and target string is empty, just declare
* victory. OTOH, if target string isn't empty, zero matches can't work
* so we pretend the min is 1.
*/
min_matches = t->min;
if (min_matches <= 0) {
| | > | 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 |
/*
* If zero matches are allowed, and target string is empty, just declare
* victory. OTOH, if target string isn't empty, zero matches can't work
* so we pretend the min is 1.
*/
min_matches = t->min;
if (min_matches <= 0) {
if (begin == end) {
return REG_OKAY;
}
min_matches = 1;
}
/*
* We need workspace to track the endpoints of each sub-match. Normally
* we consider only nonzero-length sub-matches, so there can be at most
* end-begin of them. However, if min is larger than that, we will also
|
| ︙ | ︙ | |||
1227 1228 1229 1230 1231 1232 1233 | /* disallow zero-length match unless necessary to achieve min */ if (limit == endpts[k - 1] && limit != end && (k >= min_matches || min_matches - k < end - limit)) limit++; /* if this is the last allowed sub-match, it must reach to the end */ | | > | | > | > | > | 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 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 |
/* disallow zero-length match unless necessary to achieve min */
if (limit == endpts[k - 1] &&
limit != end &&
(k >= min_matches || min_matches - k < end - limit))
limit++;
/* if this is the last allowed sub-match, it must reach to the end */
if ((size_t)k >= max_matches) {
limit = end;
}
/* try to find an endpoint for the k'th sub-match */
endpts[k] = shortest(v, d, endpts[k - 1], limit, end,
(chr **) NULL, (int *) NULL);
if (endpts[k] == NULL) {
/* no match possible, so see if we can lengthen previous one */
k--;
goto backtrack;
}
MDEBUG(("%d: working endpoint %d: %" TCL_Z_MODIFIER "u\n",
t->id, k, LOFF(endpts[k])));
/* k'th sub-match can no longer be considered verified */
if (nverified >= k) {
nverified = k - 1;
}
if (endpts[k] != end) {
/* haven't reached end yet, try another iteration if allowed */
if ((size_t)k >= max_matches) {
/* must try to lengthen some previous match */
k--;
goto backtrack;
}
k++;
limit = endpts[k - 1];
continue;
}
/*
* We've identified a way to divide the string into k sub-matches
* that works so far as the child DFA can tell. If k is an allowed
* number of matches, start the slow part: recurse to verify each
* sub-match. We always have k <= max_matches, needn't check that.
*/
if (k < min_matches) {
goto backtrack;
}
MDEBUG(("%d: verifying %d..%d\n", t->id, nverified + 1, k));
for (i = nverified + 1; i <= k; i++) {
zaptreesubs(v, t->left);
er = cdissect(v, t->left, endpts[i - 1], endpts[i]);
if (er == REG_OKAY) {
nverified = i;
continue;
}
if (er == REG_NOMATCH) {
break;
}
/* oops, something failed */
FREE(endpts);
return er;
}
if (i > k) {
/* satisfaction */
|
| ︙ | ︙ |
Changes to generic/regguts.h.
| ︙ | ︙ | |||
199 200 201 202 203 204 205 |
/*
* Interface definitions for locale-interface functions in locale.c.
*/
/* Representation of a set of characters. */
struct cvec {
| | | | | | 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 |
/*
* Interface definitions for locale-interface functions in locale.c.
*/
/* Representation of a set of characters. */
struct cvec {
size_t nchrs; /* number of chrs */
size_t chrspace; /* number of chrs possible */
chr *chrs; /* pointer to vector of chrs */
size_t nranges; /* number of ranges (chr pairs) */
size_t rangespace; /* number of chrs possible */
chr *ranges; /* pointer to vector of chr pairs */
};
/*
* definitions for non-deterministic finite autmaton (NFA) internal
* representation
*
|
| ︙ | ︙ | |||
238 239 240 241 242 243 244 |
struct arcbatch { /* for bulk allocation of arcs */
struct arcbatch *next;
#define ABSIZE 10
struct arc a[ABSIZE];
};
struct state {
| | | | | | | | 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 |
struct arcbatch { /* for bulk allocation of arcs */
struct arcbatch *next;
#define ABSIZE 10
struct arc a[ABSIZE];
};
struct state {
size_t no;
#define FREESTATE ((size_t)-1)
char flag; /* marks special states */
size_t nins; /* number of inarcs */
struct arc *ins; /* chain of inarcs */
size_t nouts; /* number of outarcs */
struct arc *outs; /* chain of outarcs */
struct arc *free; /* chain of free arcs */
struct state *tmp; /* temporary for traversal algorithms */
struct state *next; /* chain for traversing all */
struct state *prev; /* back chain */
struct arcbatch oas; /* first arcbatch, avoid malloc in easy case */
size_t noas; /* number of arcs used in first arcbatch */
};
struct nfa {
struct state *pre; /* pre-initial state */
struct state *init; /* initial state */
struct state *final; /* final state */
struct state *post; /* post-final state */
size_t nstates; /* for numbering states */
struct state *states; /* state-chain header */
struct state *slast; /* tail of the chain */
struct state *free; /* free list */
struct colormap *cm; /* the color map */
color bos[2]; /* colors, if any, assigned to BOS and BOL */
color eos[2]; /* colors, if any, assigned to EOS and EOL */
struct vars *v; /* simplifies compile error reporting */
|
| ︙ | ︙ | |||
286 287 288 289 290 291 292 |
* Plain arcs just store the transition color number as "co". LACON arcs
* store the lookahead constraint number plus cnfa.ncolors as "co". LACON
* arcs can be distinguished from plain by testing for co >= cnfa.ncolors.
*/
struct carc {
color co; /* COLORLESS is list terminator */
| | | | | | 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 |
* Plain arcs just store the transition color number as "co". LACON arcs
* store the lookahead constraint number plus cnfa.ncolors as "co". LACON
* arcs can be distinguished from plain by testing for co >= cnfa.ncolors.
*/
struct carc {
color co; /* COLORLESS is list terminator */
size_t to; /* next-state number */
};
struct cnfa {
size_t nstates; /* number of states */
int ncolors; /* number of colors */
int flags;
#define HASLACONS 01 /* uses lookahead constraints */
size_t pre; /* setup state number */
size_t post; /* teardown state number */
color bos[2]; /* colors, if any, assigned to BOS and BOL */
color eos[2]; /* colors, if any, assigned to EOS and EOL */
char *stflags; /* vector of per-state flags bytes */
#define CNFA_NOPROGRESS 01 /* flag bit for a no-progress state */
struct carc **states; /* vector of pointers to outarc lists */
/* states[n] are pointers into a single malloc'd array of arcs */
struct carc *arcs; /* the area for the lists */
|
| ︙ | ︙ | |||
392 393 394 395 396 397 398 |
int magic;
#define GUTSMAGIC 0xFED9
int cflags; /* copy of compile flags */
long info; /* copy of re_info */
size_t nsub; /* copy of re_nsub */
struct subre *tree;
struct cnfa search; /* for fast preliminary search */
| | | | 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 |
int magic;
#define GUTSMAGIC 0xFED9
int cflags; /* copy of compile flags */
long info; /* copy of re_info */
size_t nsub; /* copy of re_nsub */
struct subre *tree;
struct cnfa search; /* for fast preliminary search */
size_t ntree; /* number of subre's, plus one */
struct colormap cmap;
int (*compare) (const chr *, const chr *, size_t);
struct subre *lacons; /* lookahead-constraint vector */
size_t nlacons; /* size of lacons */
};
/*
* Magic for allocating a variable workspace. This default version is
* stack-hungry.
*/
|
| ︙ | ︙ |
Changes to generic/tcl.decls.
| ︙ | ︙ | |||
36 37 38 39 40 41 42 |
const char *name, const char *version, int exact,
void *clientDataPtr)
}
declare 2 {
TCL_NORETURN void Tcl_Panic(const char *format, ...)
}
declare 3 {
| | | | | | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 |
const char *name, const char *version, int exact,
void *clientDataPtr)
}
declare 2 {
TCL_NORETURN void Tcl_Panic(const char *format, ...)
}
declare 3 {
void *Tcl_Alloc(TCL_HASH_TYPE size)
}
declare 4 {
void Tcl_Free(void *ptr)
}
declare 5 {
void *Tcl_Realloc(void *ptr, TCL_HASH_TYPE size)
}
declare 6 {
void *Tcl_DbCkalloc(TCL_HASH_TYPE size, const char *file, int line)
}
declare 7 {
void Tcl_DbCkfree(void *ptr, const char *file, int line)
}
declare 8 {
void *Tcl_DbCkrealloc(void *ptr, TCL_HASH_TYPE size,
const char *file, int line)
}
# Tcl_CreateFileHandler and Tcl_DeleteFileHandler are only available on unix,
# but they are part of the old generic interface, so we include them here for
# compatibility reasons.
|
| ︙ | ︙ | |||
85 86 87 88 89 90 91 |
declare 15 {
void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...)
}
declare 16 {
void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, size_t length)
}
declare 17 {
| | | | | | 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 |
declare 15 {
void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...)
}
declare 16 {
void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, size_t length)
}
declare 17 {
Tcl_Obj *Tcl_ConcatObj(size_t objc, Tcl_Obj *const objv[])
}
declare 18 {
int Tcl_ConvertToType(Tcl_Interp *interp, Tcl_Obj *objPtr,
const Tcl_ObjType *typePtr)
}
declare 19 {
void Tcl_DbDecrRefCount(Tcl_Obj *objPtr, const char *file, int line)
}
declare 20 {
void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, int line)
}
declare 21 {
int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line)
}
# Removed in 9.0 (changed to macro):
#declare 22 {
# Tcl_Obj *Tcl_DbNewBooleanObj(int intValue, const char *file, int line)
#}
declare 23 {
Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes,
size_t numBytes, const char *file, int line)
}
declare 24 {
Tcl_Obj *Tcl_DbNewDoubleObj(double doubleValue, const char *file,
int line)
}
declare 25 {
Tcl_Obj *Tcl_DbNewListObj(size_t objc, Tcl_Obj *const *objv,
const char *file, int line)
}
# Removed in 9.0 (changed to macro):
#declare 26 {
# Tcl_Obj *Tcl_DbNewLongObj(long longValue, const char *file, int line)
#}
declare 27 {
|
| ︙ | ︙ | |||
140 141 142 143 144 145 146 147 |
declare 31 {
int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, int *intPtr)
}
declare 32 {
int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
int *intPtr)
}
declare 33 {
| > | | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 |
declare 31 {
int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, int *intPtr)
}
declare 32 {
int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
int *intPtr)
}
# Only available in Tcl 8.x, NULL in Tcl 9.0
declare 33 {
unsigned char *TclGetByteArrayFromObj(Tcl_Obj *objPtr, int *numBytesPtr)
}
declare 34 {
int Tcl_GetDouble(Tcl_Interp *interp, const char *src, double *doublePtr)
}
declare 35 {
int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
double *doublePtr)
|
| ︙ | ︙ | |||
182 183 184 185 186 187 188 |
Tcl_Obj *elemListPtr)
}
declare 44 {
int Tcl_ListObjAppendElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Obj *objPtr)
}
declare 45 {
| | | | | | | | 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 219 220 221 222 223 224 225 226 227 |
Tcl_Obj *elemListPtr)
}
declare 44 {
int Tcl_ListObjAppendElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Obj *objPtr)
}
declare 45 {
int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr,
int *objcPtr, Tcl_Obj ***objvPtr)
}
declare 46 {
int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t index,
Tcl_Obj **objPtrPtr)
}
declare 47 {
int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
int *lengthPtr)
}
declare 48 {
int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t first,
size_t count, size_t objc, Tcl_Obj *const objv[])
}
# Removed in 9.0 (changed to macro):
#declare 49 {
# Tcl_Obj *Tcl_NewBooleanObj(int intValue)
#}
declare 50 {
Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, size_t numBytes)
}
declare 51 {
Tcl_Obj *Tcl_NewDoubleObj(double doubleValue)
}
# Removed in 9.0 (changed to macro):
#declare 52 {
# Tcl_Obj *Tcl_NewIntObj(int intValue)
#}
declare 53 {
Tcl_Obj *Tcl_NewListObj(size_t objc, Tcl_Obj *const objv[])
}
# Removed in 9.0 (changed to macro):
#declare 54 {
# Tcl_Obj *Tcl_NewLongObj(long longValue)
#}
declare 55 {
Tcl_Obj *Tcl_NewObj(void)
|
| ︙ | ︙ | |||
243 244 245 246 247 248 249 |
void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue)
}
# Removed in 9.0 (changed to macro):
#declare 61 {
# void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue)
#}
declare 62 {
| | | 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 |
void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue)
}
# Removed in 9.0 (changed to macro):
#declare 61 {
# void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue)
#}
declare 62 {
void Tcl_SetListObj(Tcl_Obj *objPtr, size_t objc, Tcl_Obj *const objv[])
}
# Removed in 9.0 (changed to macro):
#declare 63 {
# void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue)
#}
declare 64 {
void Tcl_SetObjLength(Tcl_Obj *objPtr, size_t length)
|
| ︙ | ︙ | |||
308 309 310 311 312 313 314 |
declare 79 {
void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc,
void *clientData)
}
declare 80 {
void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, void *clientData)
}
| | | | < > | | | | 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 |
declare 79 {
void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc,
void *clientData)
}
declare 80 {
void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, void *clientData)
}
# Only available in Tcl 8.x, NULL in Tcl 9.0
declare 81 {
int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 82 {
int Tcl_CommandComplete(const char *cmd)
}
declare 83 {
char *Tcl_Concat(size_t argc, const char *const *argv)
}
declare 84 {
size_t Tcl_ConvertElement(const char *src, char *dst, int flags)
}
declare 85 {
size_t Tcl_ConvertCountedElement(const char *src, size_t length, char *dst,
int flags)
}
declare 86 {
int Tcl_CreateAlias(Tcl_Interp *childInterp, const char *childCmd,
Tcl_Interp *target, const char *targetCmd, size_t argc,
const char *const *argv)
}
declare 87 {
int Tcl_CreateAliasObj(Tcl_Interp *childInterp, const char *childCmd,
Tcl_Interp *target, const char *targetCmd, size_t objc,
Tcl_Obj *const objv[])
}
declare 88 {
Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr,
const char *chanName, void *instanceData, int mask)
}
declare 89 {
|
| ︙ | ︙ | |||
423 424 425 426 427 428 429 |
declare 109 {
void Tcl_DeleteHashTable(Tcl_HashTable *tablePtr)
}
declare 110 {
void Tcl_DeleteInterp(Tcl_Interp *interp)
}
declare 111 {
| | | 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 |
declare 109 {
void Tcl_DeleteHashTable(Tcl_HashTable *tablePtr)
}
declare 110 {
void Tcl_DeleteInterp(Tcl_Interp *interp)
}
declare 111 {
void Tcl_DetachPids(size_t numPids, Tcl_Pid *pidPtr)
}
declare 112 {
void Tcl_DeleteTimerHandler(Tcl_TimerToken token)
}
declare 113 {
void Tcl_DeleteTrace(Tcl_Interp *interp, Tcl_Trace trace)
}
|
| ︙ | ︙ | |||
560 561 562 563 564 565 566 |
Tcl_InterpDeleteProc **procPtr)
}
declare 151 {
Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, const char *chanName,
int *modePtr)
}
declare 152 {
| | | 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 |
Tcl_InterpDeleteProc **procPtr)
}
declare 151 {
Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, const char *chanName,
int *modePtr)
}
declare 152 {
size_t Tcl_GetChannelBufferSize(Tcl_Channel chan)
}
declare 153 {
int Tcl_GetChannelHandle(Tcl_Channel chan, int direction,
void **handlePtr)
}
declare 154 {
void *Tcl_GetChannelInstanceData(Tcl_Channel chan)
|
| ︙ | ︙ | |||
613 614 615 616 617 618 619 |
Tcl_Obj *Tcl_GetObjResult(Tcl_Interp *interp)
}
# Tcl_GetOpenFile is only available on unix, but it is a part of the old
# generic interface, so we include it here for compatibility reasons.
declare 167 {
| | | | 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 |
Tcl_Obj *Tcl_GetObjResult(Tcl_Interp *interp)
}
# Tcl_GetOpenFile is only available on unix, but it is a part of the old
# generic interface, so we include it here for compatibility reasons.
declare 167 {
int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID,
int forWriting, int checkUsage, void **filePtr)
}
# Obsolete. Should now use Tcl_FSGetPathType which is objectified
# and therefore usually faster.
declare 168 {
Tcl_PathType Tcl_GetPathType(const char *path)
}
declare 169 {
|
| ︙ | ︙ | |||
681 682 683 684 685 686 687 |
int Tcl_InterpDeleted(Tcl_Interp *interp)
}
declare 185 {
int Tcl_IsSafe(Tcl_Interp *interp)
}
# Obsolete, use Tcl_FSJoinPath
declare 186 {
| | | 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 |
int Tcl_InterpDeleted(Tcl_Interp *interp)
}
declare 185 {
int Tcl_IsSafe(Tcl_Interp *interp)
}
# Obsolete, use Tcl_FSJoinPath
declare 186 {
char *Tcl_JoinPath(size_t argc, const char *const *argv,
Tcl_DString *resultPtr)
}
declare 187 {
int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, void *addr,
int type)
}
|
| ︙ | ︙ | |||
704 705 706 707 708 709 710 |
declare 190 {
int Tcl_MakeSafe(Tcl_Interp *interp)
}
declare 191 {
Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket)
}
declare 192 {
| | | | 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 |
declare 190 {
int Tcl_MakeSafe(Tcl_Interp *interp)
}
declare 191 {
Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket)
}
declare 192 {
char *Tcl_Merge(size_t argc, const char *const *argv)
}
declare 193 {
Tcl_HashEntry *Tcl_NextHashEntry(Tcl_HashSearch *searchPtr)
}
declare 194 {
void Tcl_NotifyChannel(Tcl_Channel channel, int mask)
}
declare 195 {
Tcl_Obj *Tcl_ObjGetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, int flags)
}
declare 196 {
Tcl_Obj *Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags)
}
declare 197 {
Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, size_t argc,
const char **argv, int flags)
}
# This is obsolete, use Tcl_FSOpenFileChannel
declare 198 {
Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, const char *fileName,
const char *modeString, int permissions)
}
|
| ︙ | ︙ | |||
751 752 753 754 755 756 757 |
declare 203 {
int Tcl_PutEnv(const char *assignment)
}
declare 204 {
const char *Tcl_PosixError(Tcl_Interp *interp)
}
declare 205 {
| | | 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 |
declare 203 {
int Tcl_PutEnv(const char *assignment)
}
declare 204 {
const char *Tcl_PosixError(Tcl_Interp *interp)
}
declare 205 {
void Tcl_QueueEvent(Tcl_Event *evPtr, int position)
}
declare 206 {
size_t Tcl_Read(Tcl_Channel chan, char *bufPtr, size_t toRead)
}
declare 207 {
void Tcl_ReapDetachedProcs(void)
}
|
| ︙ | ︙ | |||
813 814 815 816 817 818 819 |
int Tcl_ServiceEvent(int flags)
}
declare 223 {
void Tcl_SetAssocData(Tcl_Interp *interp, const char *name,
Tcl_InterpDeleteProc *proc, void *clientData)
}
declare 224 {
| | | 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 |
int Tcl_ServiceEvent(int flags)
}
declare 223 {
void Tcl_SetAssocData(Tcl_Interp *interp, const char *name,
Tcl_InterpDeleteProc *proc, void *clientData)
}
declare 224 {
void Tcl_SetChannelBufferSize(Tcl_Channel chan, size_t sz)
}
declare 225 {
int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan,
const char *optionName, const char *newValue)
}
declare 226 {
int Tcl_SetCommandInfo(Tcl_Interp *interp, const char *cmdName,
|
| ︙ | ︙ | |||
837 838 839 840 841 842 843 |
void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr)
}
# Removed in 9.0 (stub entry only)
#declare 230 {
# const char *Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc)
#}
declare 231 {
| | | 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 |
void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr)
}
# Removed in 9.0 (stub entry only)
#declare 230 {
# const char *Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc)
#}
declare 231 {
size_t Tcl_SetRecursionLimit(Tcl_Interp *interp, size_t depth)
}
# Removed in 9.0, replaced by macro.
#declare 232 {
# void Tcl_SetResult(Tcl_Interp *interp, char *result,
# Tcl_FreeProc *freeProc)
#}
declare 233 {
|
| ︙ | ︙ | |||
875 876 877 878 879 880 881 |
declare 240 {
const char *Tcl_SignalMsg(int sig)
}
declare 241 {
void Tcl_SourceRCFile(Tcl_Interp *interp)
}
declare 242 {
| | | | | 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 909 910 911 912 913 |
declare 240 {
const char *Tcl_SignalMsg(int sig)
}
declare 241 {
void Tcl_SourceRCFile(Tcl_Interp *interp)
}
declare 242 {
int TclSplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr,
const char ***argvPtr)
}
# Obsolete, use Tcl_FSSplitPath
declare 243 {
void TclSplitPath(const char *path, int *argcPtr, const char ***argvPtr)
}
# Removed in 9.0 (stub entry only)
#declare 244 {
# void Tcl_StaticLibrary(Tcl_Interp *interp, const char *prefix,
# Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc)
#}
# Removed in 9.0 (stub entry only)
#declare 245 {
# int Tcl_StringMatch(const char *str, const char *pattern)
#}
# Removed in 9.0:
#declare 246 {
# int Tcl_TellOld(Tcl_Channel chan)
#}
# Removed in 9.0, replaced by macro.
#declare 247 {
# int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags,
# Tcl_VarTraceProc *proc, void *clientData)
#}
declare 248 {
int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2,
int flags, Tcl_VarTraceProc *proc, void *clientData)
}
declare 249 {
char *Tcl_TranslateFileName(Tcl_Interp *interp, const char *name,
|
| ︙ | ︙ | |||
928 929 930 931 932 933 934 |
declare 254 {
int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2,
int flags)
}
# Removed in 9.0, replaced by macro.
#declare 255 {
# void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags,
| | | 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 |
declare 254 {
int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2,
int flags)
}
# Removed in 9.0, replaced by macro.
#declare 255 {
# void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags,
# Tcl_VarTraceProc *proc, void *clientData)
#}
declare 256 {
void Tcl_UntraceVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags, Tcl_VarTraceProc *proc,
void *clientData)
}
declare 257 {
|
| ︙ | ︙ | |||
952 953 954 955 956 957 958 |
const char *part2, const char *localName, int flags)
}
declare 260 {
int Tcl_VarEval(Tcl_Interp *interp, ...)
}
# Removed in 9.0, replaced by macro.
#declare 261 {
| | | | | 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 |
const char *part2, const char *localName, int flags)
}
declare 260 {
int Tcl_VarEval(Tcl_Interp *interp, ...)
}
# Removed in 9.0, replaced by macro.
#declare 261 {
# void *Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName,
# int flags, Tcl_VarTraceProc *procPtr, void *prevClientData)
#}
declare 262 {
void *Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags, Tcl_VarTraceProc *procPtr,
void *prevClientData)
}
declare 263 {
size_t Tcl_Write(Tcl_Channel chan, const char *s, size_t slen)
}
declare 264 {
void Tcl_WrongNumArgs(Tcl_Interp *interp, size_t objc,
Tcl_Obj *const objv[], const char *message)
}
declare 265 {
int Tcl_DumpActiveMemory(const char *fileName)
}
declare 266 {
void Tcl_ValidateAllMemory(const char *file, int line)
|
| ︙ | ︙ | |||
1089 1090 1091 1092 1093 1094 1095 |
# void Tcl_DiscardResult(Tcl_SavedResult *statePtr)
#}
declare 291 {
int Tcl_EvalEx(Tcl_Interp *interp, const char *script, size_t numBytes,
int flags)
}
declare 292 {
| | | 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 |
# void Tcl_DiscardResult(Tcl_SavedResult *statePtr)
#}
declare 291 {
int Tcl_EvalEx(Tcl_Interp *interp, const char *script, size_t numBytes,
int flags)
}
declare 292 {
int Tcl_EvalObjv(Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[],
int flags)
}
declare 293 {
int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
}
declare 294 {
TCL_NORETURN void Tcl_ExitThread(int status)
|
| ︙ | ︙ | |||
1184 1185 1186 1187 1188 1189 1190 |
const char *part2, Tcl_Obj *newValuePtr, int flags)
}
declare 318 {
void Tcl_ThreadAlert(Tcl_ThreadId threadId)
}
declare 319 {
void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr,
| | | 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 |
const char *part2, Tcl_Obj *newValuePtr, int flags)
}
declare 318 {
void Tcl_ThreadAlert(Tcl_ThreadId threadId)
}
declare 319 {
void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr,
int position)
}
declare 320 {
int Tcl_UniCharAtIndex(const char *src, size_t index)
}
declare 321 {
int Tcl_UniCharToLower(int ch)
}
|
| ︙ | ︙ | |||
1330 1331 1332 1333 1334 1335 1336 |
const char **termPtr)
}
declare 361 {
int Tcl_ParseCommand(Tcl_Interp *interp, const char *start,
size_t numBytes, int nested, Tcl_Parse *parsePtr)
}
declare 362 {
| | | | 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 |
const char **termPtr)
}
declare 361 {
int Tcl_ParseCommand(Tcl_Interp *interp, const char *start,
size_t numBytes, int nested, Tcl_Parse *parsePtr)
}
declare 362 {
int Tcl_ParseExpr(Tcl_Interp *interp, const char *start,
size_t numBytes, Tcl_Parse *parsePtr)
}
declare 363 {
int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start,
size_t numBytes, Tcl_Parse *parsePtr, int append,
const char **termPtr)
}
declare 364 {
|
| ︙ | ︙ | |||
1426 1427 1428 1429 1430 1431 1432 |
int Tcl_GetChannelNames(Tcl_Interp *interp)
}
declare 389 {
int Tcl_GetChannelNamesEx(Tcl_Interp *interp, const char *pattern)
}
declare 390 {
int Tcl_ProcObjCmd(void *clientData, Tcl_Interp *interp,
| | | 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 |
int Tcl_GetChannelNames(Tcl_Interp *interp)
}
declare 389 {
int Tcl_GetChannelNamesEx(Tcl_Interp *interp, const char *pattern)
}
declare 390 {
int Tcl_ProcObjCmd(void *clientData, Tcl_Interp *interp,
size_t objc, Tcl_Obj *const objv[])
}
declare 391 {
void Tcl_ConditionFinalize(Tcl_Condition *condPtr)
}
declare 392 {
void Tcl_MutexFinalize(Tcl_Mutex *mutex)
}
|
| ︙ | ︙ | |||
1572 1573 1574 1575 1576 1577 1578 |
Tcl_CommandTraceProc *proc, void *clientData)
}
declare 427 {
void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName,
int flags, Tcl_CommandTraceProc *proc, void *clientData)
}
declare 428 {
| | | | | | 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 |
Tcl_CommandTraceProc *proc, void *clientData)
}
declare 427 {
void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName,
int flags, Tcl_CommandTraceProc *proc, void *clientData)
}
declare 428 {
void *Tcl_AttemptAlloc(TCL_HASH_TYPE size)
}
declare 429 {
void *Tcl_AttemptDbCkalloc(TCL_HASH_TYPE size, const char *file, int line)
}
declare 430 {
void *Tcl_AttemptRealloc(void *ptr, TCL_HASH_TYPE size)
}
declare 431 {
void *Tcl_AttemptDbCkrealloc(void *ptr, TCL_HASH_TYPE size,
const char *file, int line)
}
declare 432 {
int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, size_t length)
}
# TIP#10 (thread-aware channels) akupries
|
| ︙ | ︙ | |||
1693 1694 1695 1696 1697 1698 1699 |
declare 458 {
int Tcl_FSChdir(Tcl_Obj *pathPtr)
}
declare 459 {
int Tcl_FSConvertToPathType(Tcl_Interp *interp, Tcl_Obj *pathPtr)
}
declare 460 {
| | | | | 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 |
declare 458 {
int Tcl_FSChdir(Tcl_Obj *pathPtr)
}
declare 459 {
int Tcl_FSConvertToPathType(Tcl_Interp *interp, Tcl_Obj *pathPtr)
}
declare 460 {
Tcl_Obj *Tcl_FSJoinPath(Tcl_Obj *listObj, size_t elements)
}
declare 461 {
Tcl_Obj *TclFSSplitPath(Tcl_Obj *pathPtr, int *lenPtr)
}
declare 462 {
int Tcl_FSEqualPaths(Tcl_Obj *firstPtr, Tcl_Obj *secondPtr)
}
declare 463 {
Tcl_Obj *Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr)
}
declare 464 {
Tcl_Obj *Tcl_FSJoinToPath(Tcl_Obj *pathPtr, size_t objc,
Tcl_Obj *const objv[])
}
declare 465 {
void *Tcl_FSGetInternalRep(Tcl_Obj *pathPtr,
const Tcl_Filesystem *fsPtr)
}
declare 466 {
|
| ︙ | ︙ | |||
1835 1836 1837 1838 1839 1840 1841 |
Tcl_Obj **valuePtrPtr)
}
declare 496 {
int Tcl_DictObjRemove(Tcl_Interp *interp, Tcl_Obj *dictPtr,
Tcl_Obj *keyPtr)
}
declare 497 {
| | | | | 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 |
Tcl_Obj **valuePtrPtr)
}
declare 496 {
int Tcl_DictObjRemove(Tcl_Interp *interp, Tcl_Obj *dictPtr,
Tcl_Obj *keyPtr)
}
declare 497 {
int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, int *sizePtr)
}
declare 498 {
int Tcl_DictObjFirst(Tcl_Interp *interp, Tcl_Obj *dictPtr,
Tcl_DictSearch *searchPtr,
Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr)
}
declare 499 {
void Tcl_DictObjNext(Tcl_DictSearch *searchPtr,
Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr)
}
declare 500 {
void Tcl_DictObjDone(Tcl_DictSearch *searchPtr)
}
declare 501 {
int Tcl_DictObjPutKeyList(Tcl_Interp *interp, Tcl_Obj *dictPtr,
size_t keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr)
}
declare 502 {
int Tcl_DictObjRemoveKeyList(Tcl_Interp *interp, Tcl_Obj *dictPtr,
size_t keyc, Tcl_Obj *const *keyv)
}
declare 503 {
Tcl_Obj *Tcl_NewDictObj(void)
}
declare 504 {
Tcl_Obj *Tcl_DbNewDictObj(const char *file, int line)
}
|
| ︙ | ︙ | |||
1948 1949 1950 1951 1952 1953 1954 |
declare 523 {
int Tcl_LimitCheck(Tcl_Interp *interp)
}
declare 524 {
int Tcl_LimitExceeded(Tcl_Interp *interp)
}
declare 525 {
| | | 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 |
declare 523 {
int Tcl_LimitCheck(Tcl_Interp *interp)
}
declare 524 {
int Tcl_LimitExceeded(Tcl_Interp *interp)
}
declare 525 {
void Tcl_LimitSetCommands(Tcl_Interp *interp, size_t commandLimit)
}
declare 526 {
void Tcl_LimitSetTime(Tcl_Interp *interp, Tcl_Time *timeLimitPtr)
}
declare 527 {
void Tcl_LimitSetGranularity(Tcl_Interp *interp, int type, int granularity)
}
|
| ︙ | ︙ | |||
2137 2138 2139 2140 2141 2142 2143 |
declare 572 {
const char *Tcl_GetEncodingNameFromEnvironment(Tcl_DString *bufPtr)
}
# TIP#268 (extended version numbers and requirements) akupries
declare 573 {
int Tcl_PkgRequireProc(Tcl_Interp *interp, const char *name,
| | | | | 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 |
declare 572 {
const char *Tcl_GetEncodingNameFromEnvironment(Tcl_DString *bufPtr)
}
# TIP#268 (extended version numbers and requirements) akupries
declare 573 {
int Tcl_PkgRequireProc(Tcl_Interp *interp, const char *name,
size_t objc, Tcl_Obj *const objv[], void *clientDataPtr)
}
# TIP#270 (utility C routines for string formatting) dgp
declare 574 {
void Tcl_AppendObjToErrorInfo(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 575 {
void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, const char *bytes,
size_t length, size_t limit, const char *ellipsis)
}
declare 576 {
Tcl_Obj *Tcl_Format(Tcl_Interp *interp, const char *format, size_t objc,
Tcl_Obj *const objv[])
}
declare 577 {
int Tcl_AppendFormatToObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
const char *format, size_t objc, Tcl_Obj *const objv[])
}
declare 578 {
Tcl_Obj *Tcl_ObjPrintf(const char *format, ...)
}
declare 579 {
void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, const char *format, ...)
}
|
| ︙ | ︙ | |||
2191 2192 2193 2194 2195 2196 2197 |
Tcl_ObjCmdProc *nreProc, void *clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 584 {
int Tcl_NREvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
}
declare 585 {
| | | | | 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 |
Tcl_ObjCmdProc *nreProc, void *clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 584 {
int Tcl_NREvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
}
declare 585 {
int Tcl_NREvalObjv(Tcl_Interp *interp, size_t objc,
Tcl_Obj *const objv[], int flags)
}
declare 586 {
int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd, size_t objc,
Tcl_Obj *const objv[], int flags)
}
declare 587 {
void Tcl_NRAddCallback(Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr,
void *data0, void *data1, void *data2,
void *data3)
}
# For use by NR extenders, to have a simple way to also provide a (required!)
# classic objProc
declare 588 {
int Tcl_NRCallObjProc(Tcl_Interp *interp, Tcl_ObjCmdProc *objProc,
void *clientData, size_t objc, Tcl_Obj *const objv[])
}
# TIP#316 (Tcl_StatBuf reader functions) dkf
declare 589 {
unsigned Tcl_GetFSDeviceFromStat(const Tcl_StatBuf *statPtr)
}
declare 590 {
|
| ︙ | ︙ | |||
2263 2264 2265 2266 2267 2268 2269 |
declare 603 {
int Tcl_GetEnsembleParameterList(Tcl_Interp *interp, Tcl_Command token,
Tcl_Obj **paramListPtr)
}
# TIP#265 (option parser) dkf for Sam Bromley
declare 604 {
| | | 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 |
declare 603 {
int Tcl_GetEnsembleParameterList(Tcl_Interp *interp, Tcl_Command token,
Tcl_Obj **paramListPtr)
}
# TIP#265 (option parser) dkf for Sam Bromley
declare 604 {
int TclParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable,
int *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv)
}
# TIP#336 (manipulate the error line) dgp
declare 605 {
int Tcl_GetErrorLine(Tcl_Interp *interp)
}
|
| ︙ | ︙ | |||
2409 2410 2411 2412 2413 2414 2415 |
# TIP #445
declare 636 {
void Tcl_FreeInternalRep(Tcl_Obj *objPtr)
}
declare 637 {
char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes,
| | | 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 |
# TIP #445
declare 636 {
void Tcl_FreeInternalRep(Tcl_Obj *objPtr)
}
declare 637 {
char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes,
TCL_HASH_TYPE numBytes)
}
declare 638 {
Tcl_ObjInternalRep *Tcl_FetchInternalRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr)
}
declare 639 {
void Tcl_StoreInternalRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr,
const Tcl_ObjInternalRep *irPtr)
|
| ︙ | ︙ | |||
2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 |
# TIP #481
declare 651 {
char *Tcl_GetStringFromObj(Tcl_Obj *objPtr, size_t *lengthPtr)
}
declare 652 {
Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, size_t *lengthPtr)
}
declare 653 {
unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, size_t *numBytesPtr)
}
# TIP #575
declare 654 {
int Tcl_UtfCharComplete(const char *src, size_t length)
| > | 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 |
# TIP #481
declare 651 {
char *Tcl_GetStringFromObj(Tcl_Obj *objPtr, size_t *lengthPtr)
}
declare 652 {
Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, size_t *lengthPtr)
}
# Only available in Tcl 8.x, NULL in Tcl 9.0
declare 653 {
unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, size_t *numBytesPtr)
}
# TIP #575
declare 654 {
int Tcl_UtfCharComplete(const char *src, size_t length)
|
| ︙ | ︙ | |||
2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 |
const char *src, size_t srcLen, int flags, Tcl_DString *dsPtr)
}
# TIP #511
declare 660 {
int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber)
}
# TIP #617
declare 668 {
size_t Tcl_UniCharLen(const int *uniStr)
}
declare 669 {
size_t Tcl_NumUtfChars(const char *src, size_t length)
| > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 |
const char *src, size_t srcLen, int flags, Tcl_DString *dsPtr)
}
# TIP #511
declare 660 {
int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber)
}
# TIP #616
declare 661 {
int Tcl_ListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr,
size_t *objcPtr, Tcl_Obj ***objvPtr)
}
declare 662 {
int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
size_t *lengthPtr)
}
declare 663 {
int Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t *sizePtr)
}
declare 664 {
int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, size_t *argcPtr,
const char ***argvPtr)
}
declare 665 {
void Tcl_SplitPath(const char *path, size_t *argcPtr, const char ***argvPtr)
}
declare 666 {
Tcl_Obj *Tcl_FSSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr)
}
declare 667 {
int Tcl_ParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable,
size_t *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv)
}
# TIP #617
declare 668 {
size_t Tcl_UniCharLen(const int *uniStr)
}
declare 669 {
size_t Tcl_NumUtfChars(const char *src, size_t length)
|
| ︙ | ︙ | |||
2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 |
declare 672 {
Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, size_t first, size_t last)
}
declare 673 {
int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index)
}
# ----- BASELINE -- FOR -- 8.7.0 ----- #
##############################################################################
# Define the platform specific public Tcl interface. These functions are only
# available on the designated platform.
| > > > > > > > > > > > > > > > > > > > > > | 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 |
declare 672 {
Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, size_t first, size_t last)
}
declare 673 {
int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index)
}
declare 676 {
Tcl_Command Tcl_CreateObjCommand2(Tcl_Interp *interp,
const char *cmdName,
Tcl_ObjCmdProc2 *proc2, void *clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 677 {
Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, int level, int flags,
Tcl_CmdObjTraceProc2 *objProc2, void *clientData,
Tcl_CmdObjTraceDeleteProc *delProc)
}
declare 678 {
Tcl_Command Tcl_NRCreateCommand2(Tcl_Interp *interp,
const char *cmdName, Tcl_ObjCmdProc2 *proc,
Tcl_ObjCmdProc2 *nreProc2, void *clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 679 {
int Tcl_NRCallObjProc2(Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2,
void *clientData, size_t objc, Tcl_Obj *const objv[])
}
# ----- BASELINE -- FOR -- 8.7.0 ----- #
##############################################################################
# Define the platform specific public Tcl interface. These functions are only
# available on the designated platform.
|
| ︙ | ︙ | |||
2564 2565 2566 2567 2568 2569 2570 |
}
##############################################################################
# Public functions that are not accessible via the stubs table.
export {
| | | 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 |
}
##############################################################################
# Public functions that are not accessible via the stubs table.
export {
void Tcl_MainEx(size_t argc, char **argv, Tcl_AppInitProc *appInitProc,
Tcl_Interp *interp)
}
export {
void Tcl_StaticLibrary(Tcl_Interp *interp, const char *prefix,
Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc)
}
export {
|
| ︙ | ︙ |
Changes to generic/tcl.h.
| ︙ | ︙ | |||
43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | * win/tcl.m4 (not patchlevel) * README (sections 0 and 2, with and without separator) * macosx/Tcl-Common.xcconfig (not patchlevel) 1 LOC * win/README (not patchlevel) (sections 0 and 2) * unix/tcl.spec (1 LOC patch) */ #define TCL_MAJOR_VERSION 9 #define TCL_MINOR_VERSION 0 #define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE #define TCL_RELEASE_SERIAL 4 #define TCL_VERSION "9.0" #define TCL_PATCH_LEVEL "9.0a4" | > > > > > | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 | * win/tcl.m4 (not patchlevel) * README (sections 0 and 2, with and without separator) * macosx/Tcl-Common.xcconfig (not patchlevel) 1 LOC * win/README (not patchlevel) (sections 0 and 2) * unix/tcl.spec (1 LOC patch) */ #if !defined(TCL_MAJOR_VERSION) #define TCL_MAJOR_VERSION 9 #endif #if TCL_MAJOR_VERSION != 9 #error "This header-file is for Tcl 9 only" #endif #define TCL_MINOR_VERSION 0 #define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE #define TCL_RELEASE_SERIAL 4 #define TCL_VERSION "9.0" #define TCL_PATCH_LEVEL "9.0a4" |
| ︙ | ︙ | |||
303 304 305 306 307 308 309 | # endif #endif /* !TCL_Z_MODIFIER */ #define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val))) #define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val))) #define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val))) #define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) | > > > | | > > > > > > > > > > > > | 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 |
# endif
#endif /* !TCL_Z_MODIFIER */
#define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val)))
#define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val)))
#define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val)))
#define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val)))
#ifdef _WIN32
# if TCL_MAJOR_VERSION > 8
typedef struct __stat64 Tcl_StatBuf;
# elif defined(_WIN64) || defined(_USE_64BIT_TIME_T)
typedef struct __stat64 Tcl_StatBuf;
# elif (defined(_MSC_VER) && (_MSC_VER < 1400)) || defined(_USE_32BIT_TIME_T)
typedef struct _stati64 Tcl_StatBuf;
# else
typedef struct _stat32i64 Tcl_StatBuf;
# endif
#elif defined(__CYGWIN__)
typedef struct {
dev_t st_dev;
unsigned short st_ino;
unsigned short st_mode;
short st_nlink;
short st_uid;
short st_gid;
/* Here is a 2-byte gap */
dev_t st_rdev;
/* Here is a 4-byte gap */
long long st_size;
#if TCL_MAJOR_VERSION > 8
struct {long long tv_sec;} st_atim;
struct {long long tv_sec;} st_mtim;
struct {long long tv_sec;} st_ctim;
#else
struct {long tv_sec;} st_atim;
struct {long tv_sec;} st_mtim;
struct {long tv_sec;} st_ctim;
/* Here is a 4-byte gap */
#endif
} Tcl_StatBuf;
#elif defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__)
typedef struct stat64 Tcl_StatBuf;
#else
typedef struct stat Tcl_StatBuf;
#endif
|
| ︙ | ︙ | |||
531 532 533 534 535 536 537 538 539 540 541 542 543 544 | int argc, const char *argv[]); typedef void (Tcl_CmdTraceProc) (void *clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc, void *cmdClientData, int argc, const char *argv[]); typedef int (Tcl_CmdObjTraceProc) (void *clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandInfo, int objc, struct Tcl_Obj *const *objv); typedef void (Tcl_CmdObjTraceDeleteProc) (void *clientData); typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr, struct Tcl_Obj *dupPtr); typedef int (Tcl_EncodingConvertProc) (void *clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); #define Tcl_EncodingFreeProc Tcl_FreeProc | > > > | 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 | int argc, const char *argv[]); typedef void (Tcl_CmdTraceProc) (void *clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc, void *cmdClientData, int argc, const char *argv[]); typedef int (Tcl_CmdObjTraceProc) (void *clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandInfo, int objc, struct Tcl_Obj *const *objv); typedef int (Tcl_CmdObjTraceProc2) (void *clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandInfo, size_t objc, struct Tcl_Obj *const *objv); typedef void (Tcl_CmdObjTraceDeleteProc) (void *clientData); typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr, struct Tcl_Obj *dupPtr); typedef int (Tcl_EncodingConvertProc) (void *clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); #define Tcl_EncodingFreeProc Tcl_FreeProc |
| ︙ | ︙ | |||
553 554 555 556 557 558 559 560 561 562 563 564 565 566 | typedef void (Tcl_FreeProc) (void *blockPtr); typedef void (Tcl_IdleProc) (void *clientData); typedef void (Tcl_InterpDeleteProc) (void *clientData, Tcl_Interp *interp); typedef void (Tcl_NamespaceDeleteProc) (void *clientData); typedef int (Tcl_ObjCmdProc) (void *clientData, Tcl_Interp *interp, int objc, struct Tcl_Obj *const *objv); typedef int (Tcl_LibraryInitProc) (Tcl_Interp *interp); typedef int (Tcl_LibraryUnloadProc) (Tcl_Interp *interp, int flags); typedef void (Tcl_PanicProc) (const char *format, ...); typedef void (Tcl_TcpAcceptProc) (void *callbackData, Tcl_Channel chan, char *address, int port); typedef void (Tcl_TimerProc) (void *clientData); typedef int (Tcl_SetFromAnyProc) (Tcl_Interp *interp, struct Tcl_Obj *objPtr); | > > | 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 | typedef void (Tcl_FreeProc) (void *blockPtr); typedef void (Tcl_IdleProc) (void *clientData); typedef void (Tcl_InterpDeleteProc) (void *clientData, Tcl_Interp *interp); typedef void (Tcl_NamespaceDeleteProc) (void *clientData); typedef int (Tcl_ObjCmdProc) (void *clientData, Tcl_Interp *interp, int objc, struct Tcl_Obj *const *objv); typedef int (Tcl_ObjCmdProc2) (void *clientData, Tcl_Interp *interp, size_t objc, struct Tcl_Obj *const *objv); typedef int (Tcl_LibraryInitProc) (Tcl_Interp *interp); typedef int (Tcl_LibraryUnloadProc) (Tcl_Interp *interp, int flags); typedef void (Tcl_PanicProc) (const char *format, ...); typedef void (Tcl_TcpAcceptProc) (void *callbackData, Tcl_Channel chan, char *address, int port); typedef void (Tcl_TimerProc) (void *clientData); typedef int (Tcl_SetFromAnyProc) (Tcl_Interp *interp, struct Tcl_Obj *objPtr); |
| ︙ | ︙ | |||
715 716 717 718 719 720 721 |
* WARNING!! The structure definition must be kept consistent with the
* CallFrame structure in tclInt.h. If you change one, change the other.
*/
typedef struct Tcl_CallFrame {
Tcl_Namespace *nsPtr;
int dummy1;
| | | | | 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 |
* WARNING!! The structure definition must be kept consistent with the
* CallFrame structure in tclInt.h. If you change one, change the other.
*/
typedef struct Tcl_CallFrame {
Tcl_Namespace *nsPtr;
int dummy1;
size_t dummy2;
void *dummy3;
void *dummy4;
void *dummy5;
size_t dummy6;
void *dummy7;
void *dummy8;
size_t dummy9;
void *dummy10;
void *dummy11;
void *dummy12;
void *dummy13;
} Tcl_CallFrame;
/*
|
| ︙ | ︙ | |||
746 747 748 749 750 751 752 |
* Tcl_CreateCommand. The other function is typically set to a compatibility
* wrapper that does string-to-object or object-to-string argument conversions
* then calls the other function.
*/
typedef struct Tcl_CmdInfo {
int isNativeObjectProc; /* 1 if objProc was registered by a call to
| | > | < > > | 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 |
* Tcl_CreateCommand. The other function is typically set to a compatibility
* wrapper that does string-to-object or object-to-string argument conversions
* then calls the other function.
*/
typedef struct Tcl_CmdInfo {
int isNativeObjectProc; /* 1 if objProc was registered by a call to
* Tcl_CreateObjCommand; 2 if objProc was registered by
* a call to Tcl_CreateObjCommand2; 0 otherwise.
* Tcl_SetCmdInfo does not modify this field. */
Tcl_ObjCmdProc *objProc; /* Command's object-based function. */
void *objClientData; /* ClientData for object proc. */
Tcl_CmdProc *proc; /* Command's string-based function. */
void *clientData; /* ClientData for string proc. */
Tcl_CmdDeleteProc *deleteProc;
/* Function to call when command is
* deleted. */
void *deleteData; /* Value to pass to deleteProc (usually the
* same as clientData). */
Tcl_Namespace *namespacePtr;/* Points to the namespace that contains this
* command. Note that Tcl_SetCmdInfo will not
* change a command's namespace; use
* TclRenameCommand or Tcl_Eval (of 'rename')
* to do that. */
Tcl_ObjCmdProc2 *objProc2; /* Command's object2-based function. */
void *objClientData2; /* ClientData for object2 proc. */
} Tcl_CmdInfo;
/*
*----------------------------------------------------------------------------
* The structure defined below is used to hold dynamic strings. The only
* fields that clients should use are string and length, accessible via the
* macros Tcl_DStringValue and Tcl_DStringLength.
|
| ︙ | ︙ | |||
831 832 833 834 835 836 837 838 839 840 841 842 843 844 | * a table that will not live long enough to make it worthwhile. */ #define TCL_EXACT 1 #define TCL_INDEX_NULL_OK 32 #define TCL_INDEX_TEMP_TABLE 64 /* *---------------------------------------------------------------------------- * Flag values passed to Tcl_RecordAndEval, Tcl_EvalObj, Tcl_EvalObjv. * WARNING: these bit choices must not conflict with the bit choices for * evalFlag bits in tclInt.h! * * Meanings: | > > > > > > > > > > | 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 | * a table that will not live long enough to make it worthwhile. */ #define TCL_EXACT 1 #define TCL_INDEX_NULL_OK 32 #define TCL_INDEX_TEMP_TABLE 64 /* * Flags that may be passed to Tcl_UniCharToUtf. * TCL_COMBINE Combine surrogates */ #if TCL_MAJOR_VERSION > 8 # define TCL_COMBINE 0x1000000 #else # define TCL_COMBINE 0 #endif /* *---------------------------------------------------------------------------- * Flag values passed to Tcl_RecordAndEval, Tcl_EvalObj, Tcl_EvalObjv. * WARNING: these bit choices must not conflict with the bit choices for * evalFlag bits in tclInt.h! * * Meanings: |
| ︙ | ︙ | |||
944 945 946 947 948 949 950 | /* *---------------------------------------------------------------------------- * Forward declarations of Tcl_HashTable and related types. */ #ifndef TCL_HASH_TYPE | > | > > > | 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 | /* *---------------------------------------------------------------------------- * Forward declarations of Tcl_HashTable and related types. */ #ifndef TCL_HASH_TYPE #if TCL_MAJOR_VERSION > 8 # define TCL_HASH_TYPE ssize_t #else # define TCL_HASH_TYPE signed #endif #endif typedef struct Tcl_HashKeyType Tcl_HashKeyType; typedef struct Tcl_HashTable Tcl_HashTable; typedef struct Tcl_HashEntry Tcl_HashEntry; typedef TCL_HASH_TYPE (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr); |
| ︙ | ︙ | |||
1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 |
* avoid mallocs and frees). */
size_t numBuckets; /* Total number of buckets allocated at
* **bucketPtr. */
size_t numEntries; /* Total number of entries present in
* table. */
size_t rebuildSize; /* Enlarge table when numEntries gets to be
* this large. */
size_t mask; /* Mask value used in hashing function. */
int downShift; /* Shift count used in hashing function.
* Designed to use high-order bits of
* randomized keys. */
int keyType; /* Type of keys used in this table. It's
* either TCL_CUSTOM_KEYS, TCL_STRING_KEYS,
* TCL_ONE_WORD_KEYS, or an integer giving the
* number of ints that is the size of the
* key. */
Tcl_HashEntry *(*findProc) (Tcl_HashTable *tablePtr, const char *key);
Tcl_HashEntry *(*createProc) (Tcl_HashTable *tablePtr, const char *key,
| > > > > > | 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 |
* avoid mallocs and frees). */
size_t numBuckets; /* Total number of buckets allocated at
* **bucketPtr. */
size_t numEntries; /* Total number of entries present in
* table. */
size_t rebuildSize; /* Enlarge table when numEntries gets to be
* this large. */
#if TCL_MAJOR_VERSION > 8
size_t mask; /* Mask value used in hashing function. */
#endif
int downShift; /* Shift count used in hashing function.
* Designed to use high-order bits of
* randomized keys. */
#if TCL_MAJOR_VERSION < 9
int mask; /* Mask value used in hashing function. */
#endif
int keyType; /* Type of keys used in this table. It's
* either TCL_CUSTOM_KEYS, TCL_STRING_KEYS,
* TCL_ONE_WORD_KEYS, or an integer giving the
* number of ints that is the size of the
* key. */
Tcl_HashEntry *(*findProc) (Tcl_HashTable *tablePtr, const char *key);
Tcl_HashEntry *(*createProc) (Tcl_HashTable *tablePtr, const char *key,
|
| ︙ | ︙ | |||
1126 1127 1128 1129 1130 1131 1132 |
* dictionaries. These fields should not be accessed by code outside
* tclDictObj.c
*/
typedef struct {
void *next; /* Search position for underlying hash
* table. */
| | | 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 |
* dictionaries. These fields should not be accessed by code outside
* tclDictObj.c
*/
typedef struct {
void *next; /* Search position for underlying hash
* table. */
TCL_HASH_TYPE epoch; /* Epoch marker for dictionary being searched,
* or 0 if search has terminated. */
Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */
} Tcl_DictSearch;
/*
*----------------------------------------------------------------------------
* Flag values to pass to Tcl_DoOneEvent to disable searches for some kinds of
|
| ︙ | ︙ | |||
1159 1160 1161 1162 1163 1164 1165 |
struct Tcl_Event {
Tcl_EventProc *proc; /* Function to call to service this event. */
struct Tcl_Event *nextPtr; /* Next in list of pending events, or NULL. */
};
/*
| | | > | 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 |
struct Tcl_Event {
Tcl_EventProc *proc; /* Function to call to service this event. */
struct Tcl_Event *nextPtr; /* Next in list of pending events, or NULL. */
};
/*
* Positions to pass to Tcl_QueueEvent/Tcl_ThreadQueueEvent:
*/
typedef enum {
TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK,
TCL_QUEUE_ALERT_IF_EMPTY=4
} Tcl_QueuePosition;
/*
* Values to pass to Tcl_SetServiceMode to specify the behavior of notifier
* event routines.
*/
|
| ︙ | ︙ | |||
1763 1764 1765 1766 1767 1768 1769 |
* or more comments preceding the command. */
size_t commentSize; /* Number of bytes in comments (up through
* newline character that terminates the last
* comment). If there were no comments, this
* field is 0. */
const char *commandStart; /* First character in first word of
* command. */
| | | | | > > > > > > > | < < | | 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 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 |
* or more comments preceding the command. */
size_t commentSize; /* Number of bytes in comments (up through
* newline character that terminates the last
* comment). If there were no comments, this
* field is 0. */
const char *commandStart; /* First character in first word of
* command. */
size_t commandSize; /* Number of bytes in command, including first
* character of first word, up through the
* terminating newline, close bracket, or
* semicolon. */
size_t numWords; /* Total number of words in command. May be
* 0. */
Tcl_Token *tokenPtr; /* Pointer to first token representing the
* words of the command. Initially points to
* staticTokens, but may change to point to
* malloc-ed space if command exceeds space in
* staticTokens. */
size_t numTokens; /* Total number of tokens in command. */
size_t tokensAvailable; /* Total number of tokens available at
* *tokenPtr. */
int errorType; /* One of the parsing error types defined
* above. */
#if TCL_MAJOR_VERSION > 8
int incomplete; /* This field is set to 1 by Tcl_ParseCommand
* if the command appears to be incomplete.
* This information is used by
* Tcl_CommandComplete. */
#endif
/*
* The fields below are intended only for the private use of the parser.
* They should not be used by functions that invoke Tcl_ParseCommand.
*/
const char *string; /* The original command string passed to
* Tcl_ParseCommand. */
const char *end; /* Points to the character just after the last
* one in the command string. */
Tcl_Interp *interp; /* Interpreter to use for error reporting, or
* NULL. */
const char *term; /* Points to character in string that
* terminated most recent token. Filled in by
* ParseTokens. If an error occurs, points to
* beginning of region where the error
* occurred (e.g. the open brace if the close
* brace is missing). */
#if TCL_MAJOR_VERSION < 9
int incomplete;
#endif
Tcl_Token staticTokens[NUM_STATIC_TOKENS];
/* Initial space for tokens for command. This
* space should be large enough to accommodate
* most commands; dynamic space is allocated
* for very large commands that don't fit
* here. */
} Tcl_Parse;
|
| ︙ | ︙ | |||
1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 | * (or perhaps 1 if we want to support a non-unicode enabled core). If > 3, * then Tcl_UniChar must be 4-bytes in size (UCS-4) (the default). If == 3, * then Tcl_UniChar must be 2-bytes in size (UTF-16). Since Tcl 9.0, UCS-4 * mode is the default and recommended mode. */ #ifndef TCL_UTF_MAX #define TCL_UTF_MAX 4 #endif /* * This represents a Unicode character. Any changes to this should also be * reflected in regcustom.h. */ | > > > > | 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 | * (or perhaps 1 if we want to support a non-unicode enabled core). If > 3, * then Tcl_UniChar must be 4-bytes in size (UCS-4) (the default). If == 3, * then Tcl_UniChar must be 2-bytes in size (UTF-16). Since Tcl 9.0, UCS-4 * mode is the default and recommended mode. */ #ifndef TCL_UTF_MAX #if TCL_MAJOR_VERSION > 8 #define TCL_UTF_MAX 4 #else #define TCL_UTF_MAX 3 #endif #endif /* * This represents a Unicode character. Any changes to this should also be * reflected in regcustom.h. */ |
| ︙ | ︙ | |||
2141 2142 2143 2144 2145 2146 2147 | /* *---------------------------------------------------------------------------- * The following constant is used to test for older versions of Tcl in the * stubs tables. */ | > | > > > | 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 | /* *---------------------------------------------------------------------------- * The following constant is used to test for older versions of Tcl in the * stubs tables. */ #if TCL_MAJOR_VERSION > 8 # define TCL_STUB_MAGIC ((int) 0xFCA3BACB + (int) sizeof(void *)) #else # define TCL_STUB_MAGIC ((int) 0xFCA3BACF) #endif /* * The following function is required to be defined in all stubs aware * extensions. The function is actually implemented in the stub library, not * the main Tcl library, although there is a trivial implementation in the * main library in case an extension is statically linked into an application. */ |
| ︙ | ︙ | |||
2193 2194 2195 2196 2197 2198 2199 | /* * Public functions that are not accessible via the stubs table. * Tcl_GetMemoryInfo is needed for AOLserver. [Bug 1868171] */ #define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \ ((Tcl_SetPanicProc(Tcl_ConsolePanic), Tcl_CreateInterp()))) | | | 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 | /* * Public functions that are not accessible via the stubs table. * Tcl_GetMemoryInfo is needed for AOLserver. [Bug 1868171] */ #define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \ ((Tcl_SetPanicProc(Tcl_ConsolePanic), Tcl_CreateInterp()))) EXTERN TCL_NORETURN void Tcl_MainEx(size_t argc, char **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version, int exact); EXTERN const char * Tcl_InitSubsystems(void); EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); EXTERN const char * Tcl_FindExecutable(const char *argv0); EXTERN const char * Tcl_SetPreInitScript(const char *string); |
| ︙ | ︙ | |||
2221 2222 2223 2224 2225 2226 2227 | EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); #endif #if defined(_WIN32) && defined(UNICODE) #ifndef USE_TCL_STUBS # define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg))) #endif # define Tcl_MainEx Tcl_MainExW | | | | | | 2281 2282 2283 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 |
EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv);
#endif
#if defined(_WIN32) && defined(UNICODE)
#ifndef USE_TCL_STUBS
# define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg)))
#endif
# define Tcl_MainEx Tcl_MainExW
EXTERN TCL_NORETURN void Tcl_MainExW(size_t argc, wchar_t **argv,
Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
#endif
#if defined(USE_TCL_STUBS) && (TCL_MAJOR_VERSION > 8)
#define Tcl_SetPanicProc(panicProc) \
TclInitStubTable(((const char *(*)(Tcl_PanicProc *))TclStubCall((void *)panicProc))(panicProc))
#define Tcl_InitSubsystems() \
TclInitStubTable(((const char *(*)(void))TclStubCall((void *)1))())
#define Tcl_FindExecutable(argv0) \
TclInitStubTable(((const char *(*)(const char *))TclStubCall((void *)2))(argv0))
#define TclZipfs_AppHook(argcp, argvp) \
TclInitStubTable(((const char *(*)(int *, void *))TclStubCall((void *)3))(argcp, argvp))
#define Tcl_MainExW(argc, argv, appInitProc, interp) \
(void)((const char *(*)(size_t, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \
TclStubCall((void *)4))(argc, argv, appInitProc, interp)
#if !defined(_WIN32) || !defined(UNICODE)
#define Tcl_MainEx(argc, argv, appInitProc, interp) \
(void)((const char *(*)(size_t, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \
TclStubCall((void *)5))(argc, argv, appInitProc, interp)
#endif
#define Tcl_StaticLibrary(interp, pkgName, initProc, safeInitProc) \
(void)((const char *(*)(Tcl_Interp *, const char *, Tcl_LibraryInitProc *, Tcl_LibraryInitProc *)) \
TclStubCall((void *)6))(interp, pkgName, initProc, safeInitProc)
#define Tcl_SetExitProc(proc) \
((Tcl_ExitProc *(*)(Tcl_ExitProc *))TclStubCall((void *)7))(proc)
|
| ︙ | ︙ |
Changes to generic/tclAssembly.c.
| ︙ | ︙ | |||
218 219 220 221 222 223 224 |
typedef struct AssemblyEnv {
CompileEnv* envPtr; /* Compilation environment being used for code
* generation */
Tcl_Parse* parsePtr; /* Parse of the current line of source */
Tcl_HashTable labelHash; /* Hash table whose keys are labels and whose
* values are 'label' objects storing the code
* offsets of the labels. */
| | | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 |
typedef struct AssemblyEnv {
CompileEnv* envPtr; /* Compilation environment being used for code
* generation */
Tcl_Parse* parsePtr; /* Parse of the current line of source */
Tcl_HashTable labelHash; /* Hash table whose keys are labels and whose
* values are 'label' objects storing the code
* offsets of the labels. */
size_t cmdLine; /* Current line number within the assembly
* code */
int* clNext; /* Invisible continuation line for
* [info frame] */
BasicBlock* head_bb; /* First basic block in the code */
BasicBlock* curr_bb; /* Current basic block */
int maxDepth; /* Maximum stack depth encountered */
int curCatchDepth; /* Current depth of catches */
|
| ︙ | ︙ | |||
273 274 275 276 277 278 279 | static void CompileEmbeddedScript(AssemblyEnv*, Tcl_Token*, const TalInstDesc*); static int DefineLabel(AssemblyEnv* envPtr, const char* label); static void DeleteMirrorJumpTable(JumptableInfo* jtPtr); static void FillInJumpOffsets(AssemblyEnv*); static int CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr, Tcl_Obj* jumpTable); | | | 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 | static void CompileEmbeddedScript(AssemblyEnv*, Tcl_Token*, const TalInstDesc*); static int DefineLabel(AssemblyEnv* envPtr, const char* label); static void DeleteMirrorJumpTable(JumptableInfo* jtPtr); static void FillInJumpOffsets(AssemblyEnv*); static int CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr, Tcl_Obj* jumpTable); static size_t FindLocalVar(AssemblyEnv* envPtr, Tcl_Token** tokenPtrPtr); static int FinishAssembly(AssemblyEnv*); static void FreeAssemblyEnv(AssemblyEnv*); static int GetBooleanOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetListIndexOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetIntegerOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetNextOperand(AssemblyEnv*, Tcl_Token**, Tcl_Obj**); |
| ︙ | ︙ | |||
959 960 961 962 963 964 965 |
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr; /* Token in the input script */
| | | | 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 |
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr; /* Token in the input script */
size_t numCommands = envPtr->numCommands;
int offset = envPtr->codeNext - envPtr->codeStart;
size_t depth = envPtr->currStackDepth;
/*
* Make sure that the command has a single arg that is a simple word.
*/
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1267 1268 1269 1270 1271 1272 1273 |
TalInstType instType; /* Type of the instruction */
Tcl_Obj* operand1Obj = NULL;
/* First operand to the instruction */
const char* operand1; /* String rep of the operand */
size_t operand1Len; /* String length of the operand */
int opnd; /* Integer representation of an operand */
int litIndex; /* Literal pool index of a constant */
| | | 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 |
TalInstType instType; /* Type of the instruction */
Tcl_Obj* operand1Obj = NULL;
/* First operand to the instruction */
const char* operand1; /* String rep of the operand */
size_t operand1Len; /* String length of the operand */
int opnd; /* Integer representation of an operand */
int litIndex; /* Literal pool index of a constant */
size_t localVar; /* LVT index of a local variable */
int flags; /* Flags for a basic block */
JumptableInfo* jtPtr; /* Pointer to a jumptable */
int infoIndex; /* Index of the jumptable in auxdata */
int status = TCL_ERROR; /* Return value from this function */
/*
* Make sure that the instruction name is known at compile time.
|
| ︙ | ︙ | |||
1362 1363 1364 1365 1366 1367 1368 |
Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean varName");
goto cleanup;
}
if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
goto cleanup;
}
localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
| | | 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 |
Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean varName");
goto cleanup;
}
if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
goto cleanup;
}
localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
if (localVar == TCL_INDEX_NONE) {
goto cleanup;
}
BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0);
TclEmitInt4(localVar, envPtr);
break;
case ASSEM_CLOCK_READ:
|
| ︙ | ︙ | |||
1422 1423 1424 1425 1426 1427 1428 |
goto cleanup;
}
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
|| CheckStrictlyPositive(interp, opnd) != TCL_OK) {
goto cleanup;
}
localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
| | | | 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 |
goto cleanup;
}
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
|| CheckStrictlyPositive(interp, opnd) != TCL_OK) {
goto cleanup;
}
localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
if (localVar == TCL_INDEX_NONE) {
goto cleanup;
}
BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1);
TclEmitInt4(localVar, envPtr);
break;
case ASSEM_DICT_UNSET:
if (parsePtr->numWords != 3) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName");
goto cleanup;
}
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
|| CheckStrictlyPositive(interp, opnd) != TCL_OK) {
goto cleanup;
}
localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
if (localVar == TCL_INDEX_NONE) {
goto cleanup;
}
BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd);
TclEmitInt4(localVar, envPtr);
break;
case ASSEM_END_CATCH:
|
| ︙ | ︙ | |||
1634 1635 1636 1637 1638 1639 1640 |
case ASSEM_LVT:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
goto cleanup;
}
localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
| | | | | | 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 |
case ASSEM_LVT:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
goto cleanup;
}
localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
if (localVar == TCL_INDEX_NONE) {
goto cleanup;
}
BBEmitInst1or4(assemEnvPtr, tblIdx, localVar, 0);
break;
case ASSEM_LVT1:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
goto cleanup;
}
localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
if (localVar == TCL_INDEX_NONE || CheckOneByte(interp, localVar)) {
goto cleanup;
}
BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0);
break;
case ASSEM_LVT1_SINT1:
if (parsePtr->numWords != 3) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName imm8");
goto cleanup;
}
localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
if (localVar == TCL_INDEX_NONE || CheckOneByte(interp, localVar)
|| GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
|| CheckSignedOneByte(interp, opnd)) {
goto cleanup;
}
BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0);
TclEmitInt1(opnd, envPtr);
break;
case ASSEM_LVT4:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
goto cleanup;
}
localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
if (localVar == TCL_INDEX_NONE) {
goto cleanup;
}
BBEmitInstInt4(assemEnvPtr, tblIdx, localVar, 0);
break;
case ASSEM_OVER:
if (parsePtr->numWords != 2) {
|
| ︙ | ︙ | |||
1737 1738 1739 1740 1741 1742 1743 |
Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName");
goto cleanup;
}
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
goto cleanup;
}
localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
| | | 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 |
Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName");
goto cleanup;
}
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
goto cleanup;
}
localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
if (localVar == TCL_INDEX_NONE) {
goto cleanup;
}
BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, 0);
TclEmitInt4(localVar, envPtr);
break;
default:
|
| ︙ | ︙ | |||
1807 1808 1809 1810 1811 1812 1813 |
*
* Save away the stack depth and reset it before compiling the script.
* We'll record the stack usage of the script in the BasicBlock, and
* accumulate it together with the stack usage of the enclosing assembly
* code.
*/
| | | | 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 |
*
* Save away the stack depth and reset it before compiling the script.
* We'll record the stack usage of the script in the BasicBlock, and
* accumulate it together with the stack usage of the enclosing assembly
* code.
*/
size_t savedStackDepth = envPtr->currStackDepth;
size_t savedMaxStackDepth = envPtr->maxStackDepth;
int savedExceptArrayNext = envPtr->exceptArrayNext;
envPtr->currStackDepth = 0;
envPtr->maxStackDepth = 0;
StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL);
switch (instPtr->tclInstCode) {
|
| ︙ | ︙ | |||
1964 1965 1966 1967 1968 1969 1970 |
*/
static int
CreateMirrorJumpTable(
AssemblyEnv* assemEnvPtr, /* Assembly environment */
Tcl_Obj* jumps) /* List of alternating keywords and labels */
{
| | | | | 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 |
*/
static int
CreateMirrorJumpTable(
AssemblyEnv* assemEnvPtr, /* Assembly environment */
Tcl_Obj* jumps) /* List of alternating keywords and labels */
{
size_t objc; /* Number of elements in the 'jumps' list */
Tcl_Obj** objv; /* Pointers to the elements in the list */
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
BasicBlock* bbPtr = assemEnvPtr->curr_bb;
/* Current basic block */
JumptableInfo* jtPtr;
Tcl_HashTable* jtHashPtr; /* Hashtable in the JumptableInfo */
Tcl_HashEntry* hashEntry; /* Entry for a key in the hashtable */
int isNew; /* Flag==1 if the key is not yet in the
* table. */
size_t i;
if (TclListObjGetElementsM(interp, jumps, &objc, &objv) != TCL_OK) {
return TCL_ERROR;
}
if (objc % 2 != 0) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"jump table must have an even number of list elements",
-1));
|
| ︙ | ︙ | |||
2291 2292 2293 2294 2295 2296 2297 | * Side effects: * Advances the token pointer. May define a new LVT slot if the variable * has not yet been seen and the execution context allows for it. * *----------------------------------------------------------------------------- */ | | | | | | | | 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 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 |
* Side effects:
* Advances the token pointer. May define a new LVT slot if the variable
* has not yet been seen and the execution context allows for it.
*
*-----------------------------------------------------------------------------
*/
static size_t
FindLocalVar(
AssemblyEnv* assemEnvPtr, /* Assembly environment */
Tcl_Token** tokenPtrPtr)
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
Tcl_Token* tokenPtr = *tokenPtrPtr;
/* INOUT: Pointer to the next token in the
* source code. */
Tcl_Obj* varNameObj; /* Name of the variable */
const char* varNameStr;
size_t varNameLen;
size_t localVar; /* Index of the variable in the LVT */
if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) {
return TCL_INDEX_NONE;
}
varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen);
if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) {
Tcl_DecrRefCount(varNameObj);
return TCL_INDEX_NONE;
}
localVar = TclFindCompiledLocal(varNameStr, varNameLen, 1, envPtr);
Tcl_DecrRefCount(varNameObj);
if (localVar == TCL_INDEX_NONE) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot use this instruction to create a variable"
" in a non-proc context", -1));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL);
}
return TCL_INDEX_NONE;
}
*tokenPtrPtr = TokenAfter(tokenPtr);
return localVar;
}
/*
*-----------------------------------------------------------------------------
|
| ︙ | ︙ | |||
3313 3314 3315 3316 3317 3318 3319 |
static int
CheckStack(
AssemblyEnv* assemEnvPtr) /* Assembly environment */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
| | | 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 |
static int
CheckStack(
AssemblyEnv* assemEnvPtr) /* Assembly environment */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
size_t maxDepth; /* Maximum stack depth overall */
/*
* Checking the head block will check all the other blocks recursively.
*/
assemEnvPtr->maxDepth = 0;
if (StackCheckBasicBlock(assemEnvPtr, assemEnvPtr->head_bb, NULL,
|
| ︙ | ︙ | |||
4122 4123 4124 4125 4126 4127 4128 | */ block = catches[catchDepth]; catchIndices[catchDepth] = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; range->nestingLevel = envPtr->exceptDepth + catchDepth; | | | 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 |
*/
block = catches[catchDepth];
catchIndices[catchDepth] =
TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
range = envPtr->exceptArrayPtr + catchIndices[catchDepth];
range->nestingLevel = envPtr->exceptDepth + catchDepth;
envPtr->maxExceptDepth=
TclMax(range->nestingLevel + 1, envPtr->maxExceptDepth);
range->codeOffset = bbPtr->startOffset;
entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
TclGetString(block->jumpTarget));
if (entryPtr == NULL) {
Tcl_Panic("undefined label in tclAssembly.c:"
|
| ︙ | ︙ | |||
4159 4160 4161 4162 4163 4164 4165 |
AssemblyEnv* assemEnvPtr) /* Assembly environment */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* bbPtr; /* Current basic block */
int rangeBase; /* Base of the foreign exception ranges when
* they are reinstalled */
| | | 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 |
AssemblyEnv* assemEnvPtr) /* Assembly environment */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* bbPtr; /* Current basic block */
int rangeBase; /* Base of the foreign exception ranges when
* they are reinstalled */
size_t rangeIndex; /* Index of the current foreign exception
* range as reinstalled */
ExceptionRange* range; /* Current foreign exception range */
unsigned char opcode; /* Current instruction's opcode */
int catchIndex; /* Index of the exception range to which the
* current instruction refers */
int i;
|
| ︙ | ︙ | |||
4186 4187 4188 4189 4190 4191 4192 |
rangeBase = envPtr->exceptArrayNext;
for (i = 0; i < bbPtr->foreignExceptionCount; ++i) {
range = bbPtr->foreignExceptions + i;
rangeIndex = TclCreateExceptRange(range->type, envPtr);
range->nestingLevel += envPtr->exceptDepth + bbPtr->catchDepth;
memcpy(envPtr->exceptArrayPtr + rangeIndex, range,
sizeof(ExceptionRange));
| | | 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 |
rangeBase = envPtr->exceptArrayNext;
for (i = 0; i < bbPtr->foreignExceptionCount; ++i) {
range = bbPtr->foreignExceptions + i;
rangeIndex = TclCreateExceptRange(range->type, envPtr);
range->nestingLevel += envPtr->exceptDepth + bbPtr->catchDepth;
memcpy(envPtr->exceptArrayPtr + rangeIndex, range,
sizeof(ExceptionRange));
if (range->nestingLevel + 1 >= envPtr->maxExceptDepth + 1) {
envPtr->maxExceptDepth = range->nestingLevel + 1;
}
}
/*
* Walk through the bytecode of the basic block, and relocate
* INST_BEGIN_CATCH4 instructions to the new locations
|
| ︙ | ︙ |
Changes to generic/tclBasic.c.
| ︙ | ︙ | |||
259 260 261 262 263 264 265 266 267 268 269 270 271 272 |
* hack because it is expected by security
* policies in the wild. */
} UnsafeEnsembleInfo;
/*
* The built-in commands, and the functions that implement them:
*/
static const CmdInfo builtInCmds[] = {
/*
* Commands in the generic core.
*/
{"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE},
| > > > > > > | 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 |
* hack because it is expected by security
* policies in the wild. */
} UnsafeEnsembleInfo;
/*
* The built-in commands, and the functions that implement them:
*/
int procObjCmd(void *clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]) {
return Tcl_ProcObjCmd(clientData, interp, objc, objv);
}
static const CmdInfo builtInCmds[] = {
/*
* Commands in the generic core.
*/
{"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE},
|
| ︙ | ︙ | |||
302 303 304 305 306 307 308 |
{"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE},
{"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE},
{"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE},
{"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE},
| | | 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 |
{"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE},
{"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE},
{"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE},
{"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE},
{"proc", procObjCmd, NULL, NULL, CMD_IS_SAFE},
{"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE},
{"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, CMD_IS_SAFE},
{"rename", Tcl_RenameObjCmd, NULL, NULL, CMD_IS_SAFE},
{"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, CMD_IS_SAFE},
{"scan", Tcl_ScanObjCmd, NULL, NULL, CMD_IS_SAFE},
{"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, CMD_IS_SAFE},
{"split", Tcl_SplitObjCmd, NULL, NULL, CMD_IS_SAFE},
|
| ︙ | ︙ | |||
598 599 600 601 602 603 604 | * Side effects: * None. * *---------------------------------------------------------------------- */ static int | | | | | 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 |
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
buildInfoObjCmd2(
void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
size_t objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc - 1 > 1) {
Tcl_WrongNumArgs(interp, 1, objv, "?option?");
return TCL_ERROR;
}
if (objc == 2) {
int len;
const char *arg = TclGetStringFromObj(objv[1], &len);
if (len == 7 && !strcmp(arg, "version")) {
|
| ︙ | ︙ | |||
682 683 684 685 686 687 688 689 690 691 692 693 694 695 |
}
Tcl_AppendResult(interp, "0", NULL);
return TCL_OK;
}
Tcl_AppendResult(interp, (char *)clientData, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateInterp --
*
* Create a new TCL command interpreter.
| > > > > > > > > > > | 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 |
}
Tcl_AppendResult(interp, "0", NULL);
return TCL_OK;
}
Tcl_AppendResult(interp, (char *)clientData, NULL);
return TCL_OK;
}
static int
buildInfoObjCmd(
void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return buildInfoObjCmd2(clientData, interp, (size_t)objc, objv);
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateInterp --
*
* Create a new TCL command interpreter.
|
| ︙ | ︙ | |||
754 755 756 757 758 759 760 761 762 763 764 765 766 767 |
Tcl_InitHashTable(&cancelTable, TCL_ONE_WORD_KEYS);
cancelTableInitialized = 1;
}
Tcl_MutexUnlock(&cancelLock);
}
if (commandTypeInit == 0) {
TclRegisterCommandTypeName(TclObjInterpProc, "proc");
TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble");
TclRegisterCommandTypeName(TclAliasObjCmd, "alias");
TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias");
TclRegisterCommandTypeName(TclChildObjCmd, "interp");
TclRegisterCommandTypeName(TclInvokeImportedCmd, "import");
| > | 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 |
Tcl_InitHashTable(&cancelTable, TCL_ONE_WORD_KEYS);
cancelTableInitialized = 1;
}
Tcl_MutexUnlock(&cancelLock);
}
#undef TclObjInterpProc
if (commandTypeInit == 0) {
TclRegisterCommandTypeName(TclObjInterpProc, "proc");
TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble");
TclRegisterCommandTypeName(TclAliasObjCmd, "alias");
TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias");
TclRegisterCommandTypeName(TclChildObjCmd, "interp");
TclRegisterCommandTypeName(TclInvokeImportedCmd, "import");
|
| ︙ | ︙ | |||
1224 1225 1226 1227 1228 1229 1230 |
* Register Tcl's version number.
* TIP #268: Full patchlevel instead of just major.minor
* TIP #599: Extended build information "+<UUID>.<tag1>.<tag2>...."
*/
Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs);
Tcl_PkgProvideEx(interp, "tcl", TCL_PATCH_LEVEL, &tclStubs);
| > | | > > > | 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 |
* Register Tcl's version number.
* TIP #268: Full patchlevel instead of just major.minor
* TIP #599: Extended build information "+<UUID>.<tag1>.<tag2>...."
*/
Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs);
Tcl_PkgProvideEx(interp, "tcl", TCL_PATCH_LEVEL, &tclStubs);
Tcl_CmdInfo info2;
Tcl_Command buildInfoCmd = Tcl_CreateObjCommand(interp, "::tcl::build-info",
buildInfoObjCmd, (void *)version, NULL);
Tcl_GetCommandInfoFromToken(buildInfoCmd, &info2);
info2.objProc2 = buildInfoObjCmd2;
info2.objClientData2 = (void *)version;
Tcl_SetCommandInfoFromToken(buildInfoCmd, &info2);
if (TclTommath_Init(interp) != TCL_OK) {
Tcl_Panic("%s", Tcl_GetStringResult(interp));
}
if (TclOOInit(interp) != TCL_OK) {
Tcl_Panic("%s", Tcl_GetStringResult(interp));
|
| ︙ | ︙ | |||
1292 1293 1294 1295 1296 1297 1298 |
Tcl_InitHashTable(&commandTypeTable, TCL_ONE_WORD_KEYS);
commandTypeInit = 1;
}
if (nameStr != NULL) {
int isNew;
hPtr = Tcl_CreateHashEntry(&commandTypeTable,
| | | | 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 |
Tcl_InitHashTable(&commandTypeTable, TCL_ONE_WORD_KEYS);
commandTypeInit = 1;
}
if (nameStr != NULL) {
int isNew;
hPtr = Tcl_CreateHashEntry(&commandTypeTable,
implementationProc, &isNew);
Tcl_SetHashValue(hPtr, (void *) nameStr);
} else {
hPtr = Tcl_FindHashEntry(&commandTypeTable,
implementationProc);
if (hPtr != NULL) {
Tcl_DeleteHashEntry(hPtr);
}
}
Tcl_MutexUnlock(&commandTypeLock);
}
|
| ︙ | ︙ | |||
1639 1640 1641 1642 1643 1644 1645 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void *
Tcl_GetAssocData(
Tcl_Interp *interp, /* Interpreter associated with. */
const char *name, /* Name of association. */
Tcl_InterpDeleteProc **procPtr)
/* Pointer to place to store address of
* current deletion callback. */
{
|
| ︙ | ︙ | |||
1772 1773 1774 1775 1776 1777 1778 |
Tcl_Interp *interp) /* Interpreter to delete. */
{
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Tcl_HashTable *hTablePtr;
ResolverScheme *resPtr, *nextResPtr;
| | | 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 |
Tcl_Interp *interp) /* Interpreter to delete. */
{
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Tcl_HashTable *hTablePtr;
ResolverScheme *resPtr, *nextResPtr;
size_t i;
/*
* Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup,
* unless we are exiting.
*/
if ((iPtr->numLevels > 0) && !TclInExit()) {
|
| ︙ | ︙ | |||
1807 1808 1809 1810 1811 1812 1813 |
/*
* TIP #285, Script cancellation support. Delete this interp from the
* global hash table of CancelInfo structs.
*/
Tcl_MutexLock(&cancelLock);
| | | 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 |
/*
* TIP #285, Script cancellation support. Delete this interp from the
* global hash table of CancelInfo structs.
*/
Tcl_MutexLock(&cancelLock);
hPtr = Tcl_FindHashEntry(&cancelTable, iPtr);
if (hPtr != NULL) {
CancelInfo *cancelInfo = (CancelInfo *)Tcl_GetHashValue(hPtr);
if (cancelInfo != NULL) {
if (cancelInfo->result != NULL) {
Tcl_Free(cancelInfo->result);
}
|
| ︙ | ︙ | |||
2002 2003 2004 2005 2006 2007 2008 |
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
ExtCmdLoc *eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hPtr);
if (eclPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(eclPtr->path);
}
| | | 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 |
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
ExtCmdLoc *eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hPtr);
if (eclPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(eclPtr->path);
}
for (i=0; i<eclPtr->nuloc; i++) {
Tcl_Free(eclPtr->loc[i].line);
}
if (eclPtr->loc != NULL) {
Tcl_Free(eclPtr->loc);
}
|
| ︙ | ︙ | |||
2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 |
* 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.
*
*----------------------------------------------------------------------
*/
Tcl_Command
Tcl_CreateObjCommand(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* previous call to Tcl_CreateInterp). */
const char *cmdName, /* Name of command. If it contains namespace
* qualifiers, the new command is put in the
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 |
* 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.
*
*----------------------------------------------------------------------
*/
typedef struct {
Tcl_ObjCmdProc2 *proc;
void *clientData; /* Arbitrary value to pass to proc function. */
Tcl_CmdDeleteProc *deleteProc;
void *deleteData; /* Arbitrary value to pass to deleteProc function. */
Tcl_ObjCmdProc2 *nreProc;
} CmdWrapperInfo;
static int cmdWrapperProc(void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj * const *objv)
{
CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
if (objc < 0) {
objc = -1;
}
return info->proc(info->clientData, interp, (size_t)objc, objv);
}
static void cmdWrapperDeleteProc(void *clientData) {
CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
clientData = info->deleteData;
Tcl_CmdDeleteProc *deleteProc = info->deleteProc;
Tcl_Free(info);
if (deleteProc != NULL) {
deleteProc(clientData);
}
}
Tcl_Command
Tcl_CreateObjCommand2(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* previous call to Tcl_CreateInterp). */
const char *cmdName, /* Name of command. If it contains namespace
* qualifiers, the new command is put in the
* specified namespace; otherwise it is put in
* the global namespace. */
Tcl_ObjCmdProc2 *proc, /* Object-based function to associate with
* name. */
void *clientData, /* Arbitrary value to pass to object
* function. */
Tcl_CmdDeleteProc *deleteProc
/* If not NULL, gives a function to call when
* this command is deleted. */
)
{
CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo));
info->proc = proc;
info->clientData = clientData;
info->deleteProc = deleteProc;
info->deleteData = clientData;
return Tcl_CreateObjCommand(interp, cmdName,
(proc ? cmdWrapperProc : NULL),
info, cmdWrapperDeleteProc);
}
Tcl_Command
Tcl_CreateObjCommand(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* previous call to Tcl_CreateInterp). */
const char *cmdName, /* Name of command. If it contains namespace
* qualifiers, the new command is put in the
|
| ︙ | ︙ | |||
3006 3007 3008 3009 3010 3011 3012 |
if ((newName == NULL) || (*newName == '\0')) {
Tcl_DeleteCommandFromToken(interp, cmd);
return TCL_OK;
}
cmdNsPtr = cmdPtr->nsPtr;
| | | 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 |
if ((newName == NULL) || (*newName == '\0')) {
Tcl_DeleteCommandFromToken(interp, cmd);
return TCL_OK;
}
cmdNsPtr = cmdPtr->nsPtr;
TclNewObj(oldFullName);
Tcl_IncrRefCount(oldFullName);
Tcl_GetCommandFullName(interp, cmd, oldFullName);
/*
* Make sure that the destination command does not already exist. The
* rename operation is like creating a command, so we should automatically
* create the containing namespaces just like Tcl_CreateCommand would.
|
| ︙ | ︙ | |||
3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 |
* returned. If the command doesn't exist then 0 is returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_SetCommandInfoFromToken(
Tcl_Command cmd,
const Tcl_CmdInfo *infoPtr)
{
Command *cmdPtr; /* Internal representation of the command */
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 |
* returned. If the command doesn't exist then 0 is returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
invokeObj2Command(
void *clientData, /* Points to command's Command structure. */
Tcl_Interp *interp, /* Current interpreter. */
size_t objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int result;
Command *cmdPtr = (Command *) clientData;
if (objc > INT_MAX) {
objc = TCL_INDEX_NONE;
}
if (cmdPtr->objProc != NULL) {
result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
} else {
result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc,
cmdPtr->objClientData, objc, objv);
}
return result;
}
static int cmdWrapper2Proc(void *clientData,
Tcl_Interp *interp,
size_t objc,
Tcl_Obj *const objv[])
{
Command *cmdPtr = (Command *)clientData;
return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
}
int
Tcl_SetCommandInfoFromToken(
Tcl_Command cmd,
const Tcl_CmdInfo *infoPtr)
{
Command *cmdPtr; /* Internal representation of the command */
|
| ︙ | ︙ | |||
3229 3230 3231 3232 3233 3234 3235 |
} else {
if (infoPtr->objProc != cmdPtr->objProc) {
cmdPtr->nreProc = NULL;
cmdPtr->objProc = infoPtr->objProc;
}
cmdPtr->objClientData = infoPtr->objClientData;
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > | 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 |
} else {
if (infoPtr->objProc != cmdPtr->objProc) {
cmdPtr->nreProc = NULL;
cmdPtr->objProc = infoPtr->objProc;
}
cmdPtr->objClientData = infoPtr->objClientData;
}
if (cmdPtr->deleteProc == cmdWrapperDeleteProc) {
CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData;
if (infoPtr->objProc2 == NULL) {
info->proc = invokeObj2Command;
info->clientData = cmdPtr;
info->nreProc = NULL;
} else {
if (infoPtr->objProc2 != info->proc) {
info->nreProc = NULL;
info->proc = infoPtr->objProc2;
}
info->clientData = infoPtr->objClientData2;
}
info->deleteProc = infoPtr->deleteProc;
info->deleteData = infoPtr->deleteData;
} else {
if ((infoPtr->objProc2 != NULL) && (infoPtr->objProc2 != cmdWrapper2Proc)) {
CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo));
info->proc = infoPtr->objProc2;
info->clientData = infoPtr->objClientData2;
info->nreProc = NULL;
info->deleteProc = infoPtr->deleteProc;
info->deleteData = infoPtr->deleteData;
cmdPtr->deleteProc = cmdWrapperDeleteProc;
cmdPtr->deleteData = info;
} else {
cmdPtr->deleteProc = infoPtr->deleteProc;
cmdPtr->deleteData = infoPtr->deleteData;
}
}
return 1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetCommandInfo --
|
| ︙ | ︙ | |||
3297 3298 3299 3300 3301 3302 3303 |
if (cmd == NULL) {
return 0;
}
/*
* Set isNativeObjectProc 1 if objProc was registered by a call to
| | > > > > > > > > > > > | | > | | > | 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 |
if (cmd == NULL) {
return 0;
}
/*
* Set isNativeObjectProc 1 if objProc was registered by a call to
* Tcl_CreateObjCommand. Set isNativeObjectProc 2 if objProc was
* registered by a call to Tcl_CreateObjCommand2. Otherwise set it to 0.
*/
cmdPtr = (Command *) cmd;
infoPtr->isNativeObjectProc =
(cmdPtr->objProc != TclInvokeStringCommand);
infoPtr->objProc = cmdPtr->objProc;
infoPtr->objClientData = cmdPtr->objClientData;
infoPtr->proc = cmdPtr->proc;
infoPtr->clientData = cmdPtr->clientData;
if (cmdPtr->deleteProc == cmdWrapperDeleteProc) {
CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData;
infoPtr->deleteProc = info->deleteProc;
infoPtr->deleteData = info->deleteData;
infoPtr->objProc2 = info->proc;
infoPtr->objClientData2 = info->clientData;
if (cmdPtr->objProc == cmdWrapperProc) {
infoPtr->isNativeObjectProc = 2;
}
} else {
infoPtr->deleteProc = cmdPtr->deleteProc;
infoPtr->deleteData = cmdPtr->deleteData;
infoPtr->objProc2 = cmdWrapper2Proc;
infoPtr->objClientData2 = cmdPtr;
}
infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr;
return 1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetCommandName --
|
| ︙ | ︙ | |||
4128 4129 4130 4131 4132 4133 4134 |
if (cancelTableInitialized != 1) {
/*
* No CancelInfo hash table (Tcl_CreateInterp has never been called?)
*/
goto done;
}
| | | 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 |
if (cancelTableInitialized != 1) {
/*
* No CancelInfo hash table (Tcl_CreateInterp has never been called?)
*/
goto done;
}
hPtr = Tcl_FindHashEntry(&cancelTable, interp);
if (hPtr == NULL) {
/*
* No CancelInfo record for this interpreter.
*/
goto done;
}
|
| ︙ | ︙ | |||
4211 4212 4213 4214 4215 4216 4217 |
*----------------------------------------------------------------------
*/
int
Tcl_EvalObjv(
Tcl_Interp *interp, /* Interpreter in which to evaluate the
* command. Also used for error reporting. */
| | | 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 |
*----------------------------------------------------------------------
*/
int
Tcl_EvalObjv(
Tcl_Interp *interp, /* Interpreter in which to evaluate the
* command. Also used for error reporting. */
size_t objc, /* Number of words in command. */
Tcl_Obj *const objv[], /* An array of pointers to objects that are
* the words that make up the command. */
int flags) /* Collection of OR-ed bits that control the
* evaluation of the script. Only
* TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and
* TCL_EVAL_NOERR are currently supported. */
{
|
| ︙ | ︙ | |||
4561 4562 4563 4564 4565 4566 4567 |
if (!(flags & TCL_EVAL_INVOKE)) {
/*
* Error messages
*/
TclNRAddCallback(interp, TEOV_Error, INT2PTR(objc),
| | | 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 |
if (!(flags & TCL_EVAL_INVOKE)) {
/*
* Error messages
*/
TclNRAddCallback(interp, TEOV_Error, INT2PTR(objc),
objv, NULL, NULL);
}
if (iPtr->numLevels == 1) {
/*
* No CONTINUE or BREAK at level 0, manage RETURN
*/
|
| ︙ | ︙ | |||
4667 4668 4669 4670 4671 4672 4673 |
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[],
Namespace *lookupNsPtr)
{
Command * cmdPtr;
Interp *iPtr = (Interp *) interp;
| | | 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 |
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[],
Namespace *lookupNsPtr)
{
Command * cmdPtr;
Interp *iPtr = (Interp *) interp;
size_t i, newObjc, handlerObjc;
Tcl_Obj **newObjv, **handlerObjv;
CallFrame *varFramePtr = iPtr->varFramePtr;
Namespace *currNsPtr = NULL;/* Used to check for and invoke any registered
* unknown command handler for the current
* namespace (TIP 181). */
Namespace *savedNsPtr = NULL;
|
| ︙ | ︙ | |||
4699 4700 4701 4702 4703 4704 4705 |
/*
* Get the list of words for the unknown handler and allocate enough space
* to hold both the handler prefix and all words of the command invokation
* itself.
*/
| | | 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 |
/*
* Get the list of words for the unknown handler and allocate enough space
* to hold both the handler prefix and all words of the command invokation
* itself.
*/
TclListObjGetElementsM(NULL, currNsPtr->unknownHandlerPtr,
&handlerObjc, &handlerObjv);
newObjc = objc + handlerObjc;
newObjv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * newObjc);
/*
* Copy command prefix from unknown handler and add on the real command's
* full argument list. Note that we only use memcpy() once because we have
|
| ︙ | ︙ | |||
4984 4985 4986 4987 4988 4989 4990 |
const char *script, /* First character of script to evaluate. */
ssize_t numBytes, /* Number of bytes in script. If -1, the
* script consists of all bytes up to the
* first NUL character. */
int flags, /* Collection of OR-ed bits that control the
* evaluation of the script. Only
* TCL_EVAL_GLOBAL is currently supported. */
| | | 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 |
const char *script, /* First character of script to evaluate. */
ssize_t numBytes, /* Number of bytes in script. If -1, the
* script consists of all bytes up to the
* first NUL character. */
int flags, /* Collection of OR-ed bits that control the
* evaluation of the script. Only
* TCL_EVAL_GLOBAL is currently supported. */
size_t line, /* The line the script starts on. */
int *clNextOuter, /* Information about an outer context for */
const char *outerScript) /* continuation line data. This is set only in
* TclSubstTokens(), to properly handle
* [...]-nested commands. The 'outerScript'
* refers to the most-outer script containing
* the embedded command, which is refered to
* by 'script'. The 'clNextOuter' refers to
|
| ︙ | ︙ | |||
5015 5016 5017 5018 5019 5020 5021 |
Tcl_Token *tokenPtr;
int bytesLeft, expandRequested, code = TCL_OK;
size_t commandLength;
CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case
* TCL_EVAL_GLOBAL was set. */
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
int gotParse = 0;
| | | 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 |
Tcl_Token *tokenPtr;
int bytesLeft, expandRequested, code = TCL_OK;
size_t commandLength;
CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case
* TCL_EVAL_GLOBAL was set. */
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
int gotParse = 0;
TCL_HASH_TYPE i, objectsUsed = 0;
/* These variables keep track of how much
* state has been allocated while evaluating
* the script, so that it can be freed
* properly if an error occurs. */
Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
CmdFrame *eeFramePtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
Tcl_Obj **stackObjArray = (Tcl_Obj **)
|
| ︙ | ︙ | |||
5150 5151 5152 5153 5154 5155 5156 | /* * TIP #280. Track lines within the words of the current * command. We use a separate pointer into the table of * continuation line locations to not lose our position for the * per-command parsing. */ | | | 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 | /* * TIP #280. Track lines within the words of the current * command. We use a separate pointer into the table of * continuation line locations to not lose our position for the * per-command parsing. */ size_t wordLine = line; const char *wordStart = parsePtr->commandStart; int *wordCLNext = clNext; unsigned int objectsNeeded = 0; unsigned int numWords = parsePtr->numWords; /* * Generate an array of objects for the words of the command. |
| ︙ | ︙ | |||
5187 5188 5189 5190 5191 5192 5193 | TclAdvanceLines(&wordLine, wordStart, tokenPtr->start); TclAdvanceContinuations(&wordLine, &wordCLNext, tokenPtr->start - outerScript); wordStart = tokenPtr->start; lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL) | | | | | | 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 |
TclAdvanceLines(&wordLine, wordStart, tokenPtr->start);
TclAdvanceContinuations(&wordLine, &wordCLNext,
tokenPtr->start - outerScript);
wordStart = tokenPtr->start;
lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL)
? (int)wordLine : -1;
if (eeFramePtr->type == TCL_LOCATION_SOURCE) {
iPtr->evalFlags |= TCL_EVAL_FILE;
}
code = TclSubstTokens(interp, tokenPtr+1,
tokenPtr->numComponents, NULL, wordLine,
wordCLNext, outerScript);
iPtr->evalFlags = 0;
if (code != TCL_OK) {
break;
}
objv[objectsUsed] = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(objv[objectsUsed]);
if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
size_t numElements;
code = TclListObjLengthM(interp, objv[objectsUsed],
&numElements);
if (code == TCL_ERROR) {
/*
* Attempt to expand a non-list.
*/
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (expanding word %" TCL_Z_MODIFIER "u)", objectsUsed));
Tcl_DecrRefCount(objv[objectsUsed]);
break;
}
expandRequested = 1;
expand[objectsUsed] = 1;
objectsNeeded += (numElements ? numElements : 1);
|
| ︙ | ︙ | |||
5256 5257 5258 5259 5260 5261 5262 |
(Tcl_Obj **)Tcl_Alloc(objectsNeeded * sizeof(Tcl_Obj *));
lines = lineSpace = (int *)Tcl_Alloc(objectsNeeded * sizeof(int));
}
objectsUsed = 0;
while (wordIdx--) {
if (expand[wordIdx]) {
| | | | 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 |
(Tcl_Obj **)Tcl_Alloc(objectsNeeded * sizeof(Tcl_Obj *));
lines = lineSpace = (int *)Tcl_Alloc(objectsNeeded * sizeof(int));
}
objectsUsed = 0;
while (wordIdx--) {
if (expand[wordIdx]) {
size_t numElements;
Tcl_Obj **elements, *temp = copy[wordIdx];
TclListObjGetElementsM(NULL, temp, &numElements,
&elements);
objectsUsed += numElements;
while (numElements--) {
lines[objIdx] = -1;
objv[objIdx--] = elements[numElements];
Tcl_IncrRefCount(elements[numElements]);
}
|
| ︙ | ︙ | |||
5449 5450 5451 5452 5453 5454 5455 | * * TIP #280 *---------------------------------------------------------------------- */ void TclAdvanceLines( | | | 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 |
*
* TIP #280
*----------------------------------------------------------------------
*/
void
TclAdvanceLines(
size_t *line,
const char *start,
const char *end)
{
const char *p;
for (p = start; p < end; p++) {
if (*p == '\n') {
|
| ︙ | ︙ | |||
5484 5485 5486 5487 5488 5489 5490 | * * TIP #280 *---------------------------------------------------------------------- */ void TclAdvanceContinuations( | | | 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 |
*
* TIP #280
*----------------------------------------------------------------------
*/
void
TclAdvanceContinuations(
size_t *line,
int **clNextPtrPtr,
int loc)
{
/*
* Track the invisible continuation lines embedded in a script, if any.
* Here they are just spaces (already). They were removed by
* TclSubstTokens via TclParseBackslash.
|
| ︙ | ︙ | |||
5620 5621 5622 5623 5624 5625 5626 |
{
Interp *iPtr = (Interp *) interp;
int i;
for (i = 1; i < objc; i++) {
CFWord *cfwPtr;
Tcl_HashEntry *hPtr =
| | | 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 |
{
Interp *iPtr = (Interp *) interp;
int i;
for (i = 1; i < objc; i++) {
CFWord *cfwPtr;
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(iPtr->lineLAPtr, objv[i]);
if (!hPtr) {
continue;
}
cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr);
if (cfwPtr->refCount-- > 1) {
|
| ︙ | ︙ | |||
5672 5673 5674 5675 5676 5677 5678 |
{
ExtCmdLoc *eclPtr;
int word;
ECL *ePtr;
CFWordBC *lastPtr = NULL;
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hePtr =
| | | | 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 |
{
ExtCmdLoc *eclPtr;
int word;
ECL *ePtr;
CFWordBC *lastPtr = NULL;
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hePtr =
Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
if (!hePtr) {
return;
}
eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr);
ePtr = &eclPtr->loc[cmd];
/*
* ePtr->nline is the number of words originally parsed.
*
* objc is the number of elements getting invoked.
*
* If they are not the same, we arrived here by compiling an
* ensemble dispatch. Ensemble subcommands that lead to script
* evaluation are not supposed to get compiled, because a command
* such as [info level] in the script can expose some of the dispatch
* shenanigans. This means that we don't have to tend to the
* housekeeping, and can escape now.
*/
if (ePtr->nline != (size_t)objc) {
return;
}
/*
* Having disposed of the ensemble cases, we can state...
* A few truths ...
* (1) ePtr->nline == objc
|
| ︙ | ︙ | |||
5778 5779 5780 5781 5782 5783 5784 |
{
Interp *iPtr = (Interp *) interp;
CFWordBC *cfwPtr = (CFWordBC *) cfPtr->litarg;
while (cfwPtr) {
CFWordBC *nextPtr = cfwPtr->nextPtr;
Tcl_HashEntry *hPtr =
| | | 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 |
{
Interp *iPtr = (Interp *) interp;
CFWordBC *cfwPtr = (CFWordBC *) cfPtr->litarg;
while (cfwPtr) {
CFWordBC *nextPtr = cfwPtr->nextPtr;
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(iPtr->lineLABCPtr, cfwPtr->obj);
CFWordBC *xPtr = (CFWordBC *)Tcl_GetHashValue(hPtr);
if (xPtr != cfwPtr) {
Tcl_Panic("TclArgumentBC Enter/Release Mismatch");
}
if (cfwPtr->prevPtr) {
|
| ︙ | ︙ | |||
5843 5844 5845 5846 5847 5848 5849 |
}
/*
* First look for location information recorded in the argument
* stack. That is nearest.
*/
| | | | 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 |
}
/*
* First look for location information recorded in the argument
* stack. That is nearest.
*/
hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, obj);
if (hPtr) {
CFWord *cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr);
*wordPtr = cfwPtr->word;
*cfPtrPtr = cfwPtr->framePtr;
return;
}
/*
* Check if the Tcl_Obj has location information as a bytecode literal, in
* that stack.
*/
hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, obj);
if (hPtr) {
CFWordBC *cfwPtr = (CFWordBC *)Tcl_GetHashValue(hPtr);
framePtr = cfwPtr->framePtr;
framePtr->data.tebc.pc = (char *) (((ByteCode *)
framePtr->data.tebc.codePtr)->codeStart + cfwPtr->pc);
*cfPtrPtr = cfwPtr->framePtr;
|
| ︙ | ︙ | |||
5953 5954 5955 5956 5957 5958 5959 |
* This function consists of three independent blocks for: direct
* evaluation of canonical lists, compilation and bytecode execution and
* finally direct evaluation. Precisely one of these blocks will be run.
*/
if (TclListObjIsCanonical(objPtr)) {
CmdFrame *eoFramePtr = NULL;
| | | 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 |
* This function consists of three independent blocks for: direct
* evaluation of canonical lists, compilation and bytecode execution and
* finally direct evaluation. Precisely one of these blocks will be run.
*/
if (TclListObjIsCanonical(objPtr)) {
CmdFrame *eoFramePtr = NULL;
size_t objc;
Tcl_Obj *listPtr, **objv;
/*
* Canonical List Optimization: In this case, we
* can safely use Tcl_EvalObjv instead and get an appreciable
* improvement in execution speed. This is because it allows us to
* avoid a setFromAny step that would just pack everything into a
|
| ︙ | ︙ | |||
6022 6023 6024 6025 6026 6027 6028 |
flags |= TCL_EVAL_SOURCE_IN_FRAME;
}
TclMarkTailcall(interp);
TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
objPtr, NULL);
| | | 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 |
flags |= TCL_EVAL_SOURCE_IN_FRAME;
}
TclMarkTailcall(interp);
TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
objPtr, NULL);
TclListObjGetElementsM(NULL, listPtr, &objc, &objv);
return TclNREvalObjv(interp, objc, objv, flags, NULL);
}
if (!(flags & TCL_EVAL_DIRECT)) {
/*
* Let the compiler/engine subsystem do the evaluation.
*
|
| ︙ | ︙ | |||
6752 6753 6754 6755 6756 6757 6758 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | | 6905 6906 6907 6908 6909 6910 6911 6912 6913 6914 6915 6916 6917 6918 6919 6920 6921 6922 6923 6924 6925 6926 6927 6928 6929 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
size_t
Tcl_SetRecursionLimit(
Tcl_Interp *interp, /* Interpreter whose nesting limit is to be
* set. */
size_t depth) /* New value for maximimum depth. */
{
Interp *iPtr = (Interp *) interp;
size_t old;
old = iPtr->maxNestingDepth;
if (depth + 1 > 1) {
iPtr->maxNestingDepth = depth;
}
return old;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
8315 8316 8317 8318 8319 8320 8321 |
*/
int
Tcl_NRCallObjProc(
Tcl_Interp *interp,
Tcl_ObjCmdProc *objProc,
void *clientData,
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 8468 8469 8470 8471 8472 8473 8474 8475 8476 8477 8478 8479 8480 8481 8482 8483 8484 8485 8486 8487 8488 8489 8490 8491 8492 8493 8494 8495 8496 8497 8498 8499 8500 8501 8502 8503 8504 8505 8506 8507 8508 8509 8510 8511 8512 8513 8514 8515 8516 8517 8518 8519 8520 8521 8522 8523 8524 8525 8526 8527 8528 8529 8530 |
*/
int
Tcl_NRCallObjProc(
Tcl_Interp *interp,
Tcl_ObjCmdProc *objProc,
void *clientData,
size_t 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);
}
int wrapperNRObjProc(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
clientData = info->clientData;
Tcl_ObjCmdProc2 *proc = info->proc;
Tcl_Free(info);
if (objc < 0) {
objc = -1;
}
return proc(clientData, interp, (size_t)objc, objv);
}
int
Tcl_NRCallObjProc2(
Tcl_Interp *interp,
Tcl_ObjCmdProc2 *objProc,
void *clientData,
size_t objc,
Tcl_Obj *const objv[])
{
if (objc > INT_MAX) {
Tcl_WrongNumArgs(interp, 1, objv, "?args?");
return TCL_ERROR;
}
NRE_callback *rootPtr = TOP_CB(interp);
CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo));
info->clientData = clientData;
info->proc = objProc;
TclNRAddCallback(interp, Dispatch, wrapperNRObjProc, info,
INT2PTR(objc), objv);
return TclNRRunCallbacks(interp, TCL_OK, rootPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_NRCreateCommand --
*
* Define a new NRE-enabled object-based command in a command table.
*
|
| ︙ | ︙ | |||
8352 8353 8354 8355 8356 8357 8358 8359 8360 8361 8362 8363 8364 8365 |
* 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.
*
*----------------------------------------------------------------------
*/
Tcl_Command
Tcl_NRCreateCommand(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* previous call to Tcl_CreateInterp). */
const char *cmdName, /* Name of command. If it contains namespace
* qualifiers, the new command is put in the
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 8544 8545 8546 8547 8548 8549 8550 8551 8552 8553 8554 8555 8556 8557 8558 8559 8560 8561 8562 8563 8564 8565 8566 8567 8568 8569 8570 8571 8572 8573 8574 8575 8576 8577 8578 8579 8580 8581 8582 8583 8584 8585 8586 8587 8588 8589 8590 8591 8592 8593 8594 8595 8596 8597 8598 8599 8600 8601 |
* 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.
*
*----------------------------------------------------------------------
*/
static int cmdWrapperNreProc(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
if (objc < 0) {
objc = -1;
}
return info->nreProc(info->clientData, interp, (size_t)objc, objv);
}
Tcl_Command
Tcl_NRCreateCommand2(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* previous call to Tcl_CreateInterp). */
const char *cmdName, /* Name of command. If it contains namespace
* qualifiers, the new command is put in the
* specified namespace; otherwise it is put in
* the global namespace. */
Tcl_ObjCmdProc2 *proc, /* Object-based function to associate with
* name, provides direct access for direct
* calls. */
Tcl_ObjCmdProc2 *nreProc, /* Object-based function to associate with
* name, provides NR implementation */
void *clientData, /* Arbitrary value to pass to object
* function. */
Tcl_CmdDeleteProc *deleteProc)
/* If not NULL, gives a function to call when
* this command is deleted. */
{
CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo));
info->proc = proc;
info->clientData = clientData;
info->nreProc = nreProc;
info->deleteProc = deleteProc;
info->deleteData = clientData;
return Tcl_NRCreateCommand(interp, cmdName,
(proc ? cmdWrapperProc : NULL),
(nreProc ? cmdWrapperNreProc : NULL),
info, cmdWrapperDeleteProc);
}
Tcl_Command
Tcl_NRCreateCommand(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* previous call to Tcl_CreateInterp). */
const char *cmdName, /* Name of command. If it contains namespace
* qualifiers, the new command is put in the
|
| ︙ | ︙ | |||
8415 8416 8417 8418 8419 8420 8421 |
return TclNREvalObjEx(interp, objPtr, flags, NULL, INT_MIN);
}
int
Tcl_NREvalObjv(
Tcl_Interp *interp, /* Interpreter in which to evaluate the
* command. Also used for error reporting. */
| | | | 8651 8652 8653 8654 8655 8656 8657 8658 8659 8660 8661 8662 8663 8664 8665 8666 8667 8668 8669 8670 8671 8672 8673 8674 8675 8676 8677 8678 8679 8680 |
return TclNREvalObjEx(interp, objPtr, flags, NULL, INT_MIN);
}
int
Tcl_NREvalObjv(
Tcl_Interp *interp, /* Interpreter in which to evaluate the
* command. Also used for error reporting. */
size_t objc, /* Number of words in command. */
Tcl_Obj *const objv[], /* An array of pointers to objects that are
* the words that make up the command. */
int flags) /* Collection of OR-ed bits that control the
* evaluation of the script. Only
* TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and
* TCL_EVAL_NOERR are currently supported. */
{
return TclNREvalObjv(interp, objc, objv, flags, NULL);
}
int
Tcl_NRCmdSwap(
Tcl_Interp *interp,
Tcl_Command cmd,
size_t objc,
Tcl_Obj *const objv[],
int flags)
{
return TclNREvalObjv(interp, objc, objv, flags|TCL_EVAL_NOERR,
(Command *) cmd);
}
|
| ︙ | ︙ | |||
8622 8623 8624 8625 8626 8627 8628 |
void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr = (Tcl_Obj *)data[0], *nsObjPtr;
Tcl_Namespace *nsPtr;
| | | | 8858 8859 8860 8861 8862 8863 8864 8865 8866 8867 8868 8869 8870 8871 8872 8873 8874 8875 |
void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr = (Tcl_Obj *)data[0], *nsObjPtr;
Tcl_Namespace *nsPtr;
size_t objc;
Tcl_Obj **objv;
TclListObjGetElementsM(interp, listPtr, &objc, &objv);
nsObjPtr = objv[0];
if (result == TCL_OK) {
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
}
if (result != TCL_OK) {
|
| ︙ | ︙ | |||
9045 9046 9047 9048 9049 9050 9051 |
static int
TclNREvalList(
void *data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
| | | | 9281 9282 9283 9284 9285 9286 9287 9288 9289 9290 9291 9292 9293 9294 9295 9296 9297 9298 9299 9300 9301 9302 9303 |
static int
TclNREvalList(
void *data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
size_t objc;
Tcl_Obj **objv;
Tcl_Obj *listPtr = (Tcl_Obj *)data[0];
Tcl_IncrRefCount(listPtr);
TclMarkTailcall(interp);
TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL);
TclListObjGetElementsM(NULL, listPtr, &objc, &objv);
return TclNREvalObjv(interp, objc, objv, 0, NULL);
}
/*
*----------------------------------------------------------------------
*
* CoroTypeObjCmd --
|
| ︙ | ︙ | |||
9307 9308 9309 9310 9311 9312 9313 |
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
CoroutineData *corPtr = (CoroutineData *)data[0];
Tcl_Obj *listPtr = (Tcl_Obj *)data[1];
size_t nargs = PTR2INT(data[2]);
void *isProbe = data[3];
| | | 9543 9544 9545 9546 9547 9548 9549 9550 9551 9552 9553 9554 9555 9556 9557 |
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
CoroutineData *corPtr = (CoroutineData *)data[0];
Tcl_Obj *listPtr = (Tcl_Obj *)data[1];
size_t nargs = PTR2INT(data[2]);
void *isProbe = data[3];
size_t objc;
Tcl_Obj **objv;
if (!isProbe) {
/*
* If this is [coroinject], add the extra arguments now.
*/
|
| ︙ | ︙ | |||
9339 9340 9341 9342 9343 9344 9345 |
* Call the user's script; we're in the right place.
*/
Tcl_IncrRefCount(listPtr);
TclMarkTailcall(interp);
TclNRAddCallback(interp, InjectHandlerPostCall, corPtr, listPtr,
INT2PTR(nargs), isProbe);
| | | 9575 9576 9577 9578 9579 9580 9581 9582 9583 9584 9585 9586 9587 9588 9589 |
* Call the user's script; we're in the right place.
*/
Tcl_IncrRefCount(listPtr);
TclMarkTailcall(interp);
TclNRAddCallback(interp, InjectHandlerPostCall, corPtr, listPtr,
INT2PTR(nargs), isProbe);
TclListObjGetElementsM(NULL, listPtr, &objc, &objv);
return TclNREvalObjv(interp, objc, objv, 0, NULL);
}
static int
InjectHandlerPostCall(
void *data[],
Tcl_Interp *interp,
|
| ︙ | ︙ |
Changes to generic/tclBinary.c.
| ︙ | ︙ | |||
337 338 339 340 341 342 343 | /* *---------------------------------------------------------------------- * * TclGetBytesFromObj -- * * Attempt to extract the value from objPtr in the representation * of a byte sequence. On success return the extracted byte sequence. | | | 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 | /* *---------------------------------------------------------------------- * * TclGetBytesFromObj -- * * Attempt to extract the value from objPtr in the representation * of a byte sequence. On success return the extracted byte sequence. * On failure, return NULL and record error message and code in * interp (if not NULL). * * Results: * NULL or pointer to array of bytes representing the ByteArray object. * Writes number of bytes in array to *numBytesPtr. * *---------------------------------------------------------------------- |
| ︙ | ︙ | |||
400 401 402 403 404 405 406 |
return NULL;
} else {
*numBytesPtr = (int) numBytes;
}
}
return bytes;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 400 401 402 403 404 405 406 407 408 409 410 411 412 413 |
return NULL;
} else {
*numBytesPtr = (int) numBytes;
}
}
return bytes;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetByteArrayLength --
*
* This procedure changes the length of the byte array for this object.
|
| ︙ | ︙ | |||
905 906 907 908 909 910 911 |
Tcl_Obj *resultPtr = NULL; /* Object holding result buffer. */
unsigned char *buffer; /* Start of result buffer. */
unsigned char *cursor; /* Current position within result buffer. */
unsigned char *maxPos; /* Greatest position within result buffer that
* cursor has visited.*/
const char *errorString;
const char *errorValue, *str;
| | < | 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 |
Tcl_Obj *resultPtr = NULL; /* Object holding result buffer. */
unsigned char *buffer; /* Start of result buffer. */
unsigned char *cursor; /* Current position within result buffer. */
unsigned char *maxPos; /* Greatest position within result buffer that
* cursor has visited.*/
const char *errorString;
const char *errorValue, *str;
size_t offset, size, length;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg ...?");
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
1004 1005 1006 1007 1008 1009 1010 |
* non-list value.
*/
if (count == BINARY_NOCOUNT) {
arg++;
count = 1;
} else {
| | | | | 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 |
* non-list value.
*/
if (count == BINARY_NOCOUNT) {
arg++;
count = 1;
} else {
size_t listc;
Tcl_Obj **listv;
/*
* The macro evals its args more than once: avoid arg++
*/
if (TclListObjGetElementsM(interp, objv[arg], &listc,
&listv) != TCL_OK) {
return TCL_ERROR;
}
arg++;
if (count == BINARY_ALL) {
count = listc;
} else if (count > listc) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"number of elements in list does not match count",
-1));
return TCL_ERROR;
}
}
offset += count*size;
|
| ︙ | ︙ | |||
1043 1044 1045 1046 1047 1048 1049 |
}
offset += count;
break;
case 'X':
if (count == BINARY_NOCOUNT) {
count = 1;
}
| | | | | | 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 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 |
}
offset += count;
break;
case 'X':
if (count == BINARY_NOCOUNT) {
count = 1;
}
if ((count > offset) || (count == BINARY_ALL)) {
count = offset;
}
if (offset > length) {
length = offset;
}
offset -= count;
break;
case '@':
if (offset > length) {
length = offset;
}
if (count == BINARY_ALL) {
offset = length;
} else if (count == BINARY_NOCOUNT) {
goto badCount;
} else {
offset = count;
}
break;
default:
errorString = str;
goto badField;
}
}
if (offset > length) {
length = offset;
}
if (length == 0) {
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
1147 1148 1149 1150 1151 1152 1153 |
last = cursor + ((count + 7) / 8);
if (count > length) {
count = length;
}
value = 0;
errorString = "binary";
if (cmd == 'B') {
| | | | 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 |
last = cursor + ((count + 7) / 8);
if (count > length) {
count = length;
}
value = 0;
errorString = "binary";
if (cmd == 'B') {
for (offset = 0; offset < count; offset++) {
value <<= 1;
if (str[offset] == '1') {
value |= 1;
} else if (str[offset] != '0') {
errorValue = str;
Tcl_DecrRefCount(resultPtr);
goto badValue;
}
if (((offset + 1) % 8) == 0) {
*cursor++ = UCHAR(value);
value = 0;
}
}
} else {
for (offset = 0; offset < count; offset++) {
value >>= 1;
if (str[offset] == '1') {
value |= 128;
} else if (str[offset] != '0') {
errorValue = str;
Tcl_DecrRefCount(resultPtr);
goto badValue;
|
| ︙ | ︙ | |||
1209 1210 1211 1212 1213 1214 1215 |
last = cursor + ((count + 1) / 2);
if (count > length) {
count = length;
}
value = 0;
errorString = "hexadecimal";
if (cmd == 'H') {
| | | | 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 |
last = cursor + ((count + 1) / 2);
if (count > length) {
count = length;
}
value = 0;
errorString = "hexadecimal";
if (cmd == 'H') {
for (offset = 0; offset < count; offset++) {
value <<= 4;
if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
errorValue = str;
Tcl_DecrRefCount(resultPtr);
goto badValue;
}
c = str[offset] - '0';
if (c > 9) {
c += ('0' - 'A') + 10;
}
if (c > 16) {
c += ('A' - 'a');
}
value |= (c & 0xF);
if (offset % 2) {
*cursor++ = (char) value;
value = 0;
}
}
} else {
for (offset = 0; offset < count; offset++) {
value >>= 4;
if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
errorValue = str;
Tcl_DecrRefCount(resultPtr);
goto badValue;
}
|
| ︙ | ︙ | |||
1282 1283 1284 1285 1286 1287 1288 |
case 'W':
case 'r':
case 'R':
case 'd':
case 'q':
case 'Q':
case 'f': {
| | | | | 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 |
case 'W':
case 'r':
case 'R':
case 'd':
case 'q':
case 'Q':
case 'f': {
size_t listc, i;
Tcl_Obj **listv;
if (count == BINARY_NOCOUNT) {
/*
* Note that we are casting away the const-ness of objv, but
* this is safe since we aren't going to modify the array.
*/
listv = (Tcl_Obj **) (objv + arg);
listc = 1;
count = 1;
} else {
TclListObjGetElementsM(interp, objv[arg], &listc, &listv);
if (count == BINARY_ALL) {
count = listc;
}
}
arg++;
for (i = 0; i < count; i++) {
if (FormatNumber(interp, cmd, listv[i], &cursor) != TCL_OK) {
Tcl_DecrRefCount(resultPtr);
return TCL_ERROR;
}
}
break;
}
|
| ︙ | ︙ | |||
1412 1413 1414 1415 1416 1417 1418 |
int flags; /* Format field flags */
const char *format; /* Pointer to current position in format
* string. */
Tcl_Obj *resultPtr = NULL; /* Object holding result buffer. */
unsigned char *buffer; /* Start of result buffer. */
const char *errorString;
const char *str;
| | < | 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 |
int flags; /* Format field flags */
const char *format; /* Pointer to current position in format
* string. */
Tcl_Obj *resultPtr = NULL; /* Object holding result buffer. */
unsigned char *buffer; /* Start of result buffer. */
const char *errorString;
const char *str;
size_t offset, size, length = 0, i;
Tcl_Obj *valuePtr, *elementPtr;
Tcl_HashTable numberCacheHash;
Tcl_HashTable *numberCachePtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
|
| ︙ | ︙ | |||
1532 1533 1534 1535 1536 1537 1538 |
}
src = buffer + offset;
TclNewObj(valuePtr);
Tcl_SetObjLength(valuePtr, count);
dest = TclGetString(valuePtr);
if (cmd == 'b') {
| | | | 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 |
}
src = buffer + offset;
TclNewObj(valuePtr);
Tcl_SetObjLength(valuePtr, count);
dest = TclGetString(valuePtr);
if (cmd == 'b') {
for (i = 0; i < count; i++) {
if (i % 8) {
value >>= 1;
} else {
value = *src++;
}
*dest++ = (char) ((value & 1) ? '1' : '0');
}
} else {
for (i = 0; i < count; i++) {
if (i % 8) {
value <<= 1;
} else {
value = *src++;
}
*dest++ = (char) ((value & 0x80) ? '1' : '0');
}
|
| ︙ | ︙ | |||
1587 1588 1589 1590 1591 1592 1593 |
}
src = buffer + offset;
TclNewObj(valuePtr);
Tcl_SetObjLength(valuePtr, count);
dest = TclGetString(valuePtr);
if (cmd == 'h') {
| | | | 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 |
}
src = buffer + offset;
TclNewObj(valuePtr);
Tcl_SetObjLength(valuePtr, count);
dest = TclGetString(valuePtr);
if (cmd == 'h') {
for (i = 0; i < count; i++) {
if (i % 2) {
value >>= 4;
} else {
value = *src++;
}
*dest++ = hexdigit[value & 0xF];
}
} else {
for (i = 0; i < count; i++) {
if (i % 2) {
value <<= 4;
} else {
value = *src++;
}
*dest++ = hexdigit[(value >> 4) & 0xF];
}
|
| ︙ | ︙ | |||
1653 1654 1655 1656 1657 1658 1659 |
scanNumber:
if (arg >= objc) {
DeleteScanNumberCache(numberCachePtr);
goto badIndex;
}
if (count == BINARY_NOCOUNT) {
| | | | | | 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 |
scanNumber:
if (arg >= objc) {
DeleteScanNumberCache(numberCachePtr);
goto badIndex;
}
if (count == BINARY_NOCOUNT) {
if (length < (size_t)size + offset) {
goto done;
}
valuePtr = ScanNumber(buffer+offset, cmd, flags,
&numberCachePtr);
offset += size;
} else {
if (count == BINARY_ALL) {
count = (length - offset) / size;
}
if ((length - offset) < (count * size)) {
goto done;
}
TclNewObj(valuePtr);
src = buffer + offset;
for (i = 0; i < count; i++) {
elementPtr = ScanNumber(src, cmd, flags, &numberCachePtr);
src += size;
Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr);
}
offset += count * size;
}
resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
TCL_LEAVE_ERR_MSG);
arg++;
if (resultPtr == NULL) {
DeleteScanNumberCache(numberCachePtr);
return TCL_ERROR;
}
break;
}
case 'x':
if (count == BINARY_NOCOUNT) {
count = 1;
}
if ((count == BINARY_ALL) || (count > (length - offset))) {
offset = length;
} else {
offset += count;
}
break;
case 'X':
if (count == BINARY_NOCOUNT) {
count = 1;
}
if ((count == BINARY_ALL) || (count > offset)) {
offset = 0;
} else {
offset -= count;
}
break;
case '@':
if (count == BINARY_NOCOUNT) {
|
| ︙ | ︙ |
Changes to generic/tclCkalloc.c.
| ︙ | ︙ | |||
123 124 125 126 127 128 129 | * explicitly initialized. This is necessary because the self initializing * mutexes use Tcl_Alloc... */ static Tcl_Mutex *ckallocMutexPtr; static int ckallocInit = 0; | < < < < < < < < < < < < < | 123 124 125 126 127 128 129 130 131 132 133 134 135 136 | * explicitly initialized. This is necessary because the self initializing * mutexes use Tcl_Alloc... */ static Tcl_Mutex *ckallocMutexPtr; static int ckallocInit = 0; /* *---------------------------------------------------------------------- * * TclInitDbCkalloc -- * * Initialize the locks used by the allocator. This is only appropriate * to call in a single threaded environment, such as during |
| ︙ | ︙ | |||
976 977 978 979 980 981 982 | * Returns a standard Tcl completion code. * * Side effects: * None. * *---------------------------------------------------------------------- */ | < < < < | 963 964 965 966 967 968 969 970 971 972 973 974 975 976 |
* Returns a standard Tcl completion code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
CheckmemCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter for evaluation. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Obj values of arguments. */
{
|
| ︙ | ︙ |
Changes to generic/tclClock.c.
| ︙ | ︙ | |||
138 139 140 141 142 143 144 | /* * Function prototypes for local procedures in this file: */ static int ConvertUTCToLocal(Tcl_Interp *, TclDateFields *, Tcl_Obj *, int); static int ConvertUTCToLocalUsingTable(Tcl_Interp *, | | | | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 | /* * Function prototypes for local procedures in this file: */ static int ConvertUTCToLocal(Tcl_Interp *, TclDateFields *, Tcl_Obj *, int); static int ConvertUTCToLocalUsingTable(Tcl_Interp *, TclDateFields *, size_t, Tcl_Obj *const[]); static int ConvertUTCToLocalUsingC(Tcl_Interp *, TclDateFields *, int); static int ConvertLocalToUTC(Tcl_Interp *, TclDateFields *, Tcl_Obj *, int); static int ConvertLocalToUTCUsingTable(Tcl_Interp *, TclDateFields *, size_t, Tcl_Obj *const[]); static int ConvertLocalToUTCUsingC(Tcl_Interp *, TclDateFields *, int); static Tcl_Obj * LookupLastTransition(Tcl_Interp *, Tcl_WideInt, size_t, Tcl_Obj *const *); static void GetYearWeekDay(TclDateFields *, int); static void GetGregorianEraYearDay(TclDateFields *, int); static void GetMonthDay(TclDateFields *); static void GetJulianDayFromEraYearWeekDay(TclDateFields *, int); static void GetJulianDayFromEraYearMonthDay(TclDateFields *, int); static int IsGregorianLeapYear(TclDateFields *); static int WeekdayOnOrBefore(int, int); |
| ︙ | ︙ | |||
743 744 745 746 747 748 749 |
static int
ConvertLocalToUTC(
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Fields of the time */
Tcl_Obj *tzdata, /* Time zone data */
int changeover) /* Julian Day of the Gregorian transition */
{
| | | | 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 |
static int
ConvertLocalToUTC(
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Fields of the time */
Tcl_Obj *tzdata, /* Time zone data */
int changeover) /* Julian Day of the Gregorian transition */
{
size_t rowc; /* Number of rows in tzdata */
Tcl_Obj **rowv; /* Pointers to the rows */
/*
* Unpack the tz data.
*/
if (TclListObjGetElementsM(interp, tzdata, &rowc, &rowv) != TCL_OK) {
return TCL_ERROR;
}
/*
* Special case: If the time zone is :localtime, the tzdata will be empty.
* Use 'mktime' to convert the time to local
*/
|
| ︙ | ︙ | |||
788 789 790 791 792 793 794 |
*----------------------------------------------------------------------
*/
static int
ConvertLocalToUTCUsingTable(
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Time to convert, with 'seconds' filled in */
| | | | 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 |
*----------------------------------------------------------------------
*/
static int
ConvertLocalToUTCUsingTable(
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Time to convert, with 'seconds' filled in */
size_t rowc, /* Number of points at which time changes */
Tcl_Obj *const rowv[]) /* Points at which time changes */
{
Tcl_Obj *row;
size_t cellc;
Tcl_Obj **cellv;
int have[8];
int nHave = 0;
int i;
int found;
/*
|
| ︙ | ︙ | |||
815 816 817 818 819 820 821 |
found = 0;
fields->tzOffset = 0;
fields->seconds = fields->localSeconds;
while (!found) {
row = LookupLastTransition(interp, fields->seconds, rowc, rowv);
if ((row == NULL)
| | | 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 |
found = 0;
fields->tzOffset = 0;
fields->seconds = fields->localSeconds;
while (!found) {
row = LookupLastTransition(interp, fields->seconds, rowc, rowv);
if ((row == NULL)
|| TclListObjGetElementsM(interp, row, &cellc,
&cellv) != TCL_OK
|| TclGetIntFromObj(interp, cellv[1],
&fields->tzOffset) != TCL_OK) {
return TCL_ERROR;
}
found = 0;
for (i = 0; !found && i < nHave; ++i) {
|
| ︙ | ︙ | |||
946 947 948 949 950 951 952 |
static int
ConvertUTCToLocal(
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Fields of the time */
Tcl_Obj *tzdata, /* Time zone data */
int changeover) /* Julian Day of the Gregorian transition */
{
| | | | 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 |
static int
ConvertUTCToLocal(
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Fields of the time */
Tcl_Obj *tzdata, /* Time zone data */
int changeover) /* Julian Day of the Gregorian transition */
{
size_t rowc; /* Number of rows in tzdata */
Tcl_Obj **rowv; /* Pointers to the rows */
/*
* Unpack the tz data.
*/
if (TclListObjGetElementsM(interp, tzdata, &rowc, &rowv) != TCL_OK) {
return TCL_ERROR;
}
/*
* Special case: If the time zone is :localtime, the tzdata will be empty.
* Use 'localtime' to convert the time to local
*/
|
| ︙ | ︙ | |||
991 992 993 994 995 996 997 |
*----------------------------------------------------------------------
*/
static int
ConvertUTCToLocalUsingTable(
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Fields of the date */
| | | | | 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 |
*----------------------------------------------------------------------
*/
static int
ConvertUTCToLocalUsingTable(
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Fields of the date */
size_t rowc, /* Number of rows in the conversion table
* (>= 1) */
Tcl_Obj *const rowv[]) /* Rows of the conversion table */
{
Tcl_Obj *row; /* Row containing the current information */
size_t cellc; /* Count of cells in the row (must be 4) */
Tcl_Obj **cellv; /* Pointers to the cells */
/*
* Look up the nearest transition time.
*/
row = LookupLastTransition(interp, fields->seconds, rowc, rowv);
if (row == NULL ||
TclListObjGetElementsM(interp, row, &cellc, &cellv) != TCL_OK ||
TclGetIntFromObj(interp, cellv[1], &fields->tzOffset) != TCL_OK) {
return TCL_ERROR;
}
/*
* Convert the time.
*/
|
| ︙ | ︙ | |||
1131 1132 1133 1134 1135 1136 1137 |
*----------------------------------------------------------------------
*/
static Tcl_Obj *
LookupLastTransition(
Tcl_Interp *interp, /* Interpreter for error messages */
Tcl_WideInt tick, /* Time from the epoch */
| | | | | 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 |
*----------------------------------------------------------------------
*/
static Tcl_Obj *
LookupLastTransition(
Tcl_Interp *interp, /* Interpreter for error messages */
Tcl_WideInt tick, /* Time from the epoch */
size_t rowc, /* Number of rows of tzdata */
Tcl_Obj *const *rowv) /* Rows in tzdata */
{
size_t l;
size_t u;
Tcl_Obj *compObj;
Tcl_WideInt compVal;
/*
* Examine the first row to make sure we're in bounds.
*/
|
| ︙ | ︙ | |||
1516 1517 1518 1519 1520 1521 1522 |
#if 0 /* BUG https://core.tcl-lang.org/tcl/tktview?name=da340d4f32 */
ym1o4 = ym1 / 4;
#else
/*
* Have to make sure quotient is truncated towards 0 when negative.
* See above bug for details. The casts are necessary.
*/
| | | | 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 |
#if 0 /* BUG https://core.tcl-lang.org/tcl/tktview?name=da340d4f32 */
ym1o4 = ym1 / 4;
#else
/*
* Have to make sure quotient is truncated towards 0 when negative.
* See above bug for details. The casts are necessary.
*/
if (ym1 >= 0) {
ym1o4 = ym1 / 4;
} else {
ym1o4 = - (int) (((unsigned int) -ym1) / 4);
}
#endif
if (ym1 % 4 < 0) {
ym1o4--;
}
ym1o100 = ym1 / 100;
|
| ︙ | ︙ |
Changes to generic/tclCmdAH.c.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 |
*/
struct ForeachState {
Tcl_Obj *bodyPtr; /* The script body of the command. */
int bodyIdx; /* The argument index of the body. */
int j, maxj; /* Number of loop iterations. */
int numLists; /* Count of value lists. */
| | | | | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 |
*/
struct ForeachState {
Tcl_Obj *bodyPtr; /* The script body of the command. */
int bodyIdx; /* The argument index of the body. */
int j, maxj; /* Number of loop iterations. */
int numLists; /* Count of value lists. */
size_t *index; /* Array of value list indices. */
size_t *varcList; /* # loop variables per list. */
Tcl_Obj ***varvList; /* Array of var name lists. */
Tcl_Obj **vCopyList; /* Copies of var name list arguments. */
size_t *argcList; /* Array of value list sizes. */
Tcl_Obj ***argvList; /* Array of value lists. */
Tcl_Obj **aCopyList; /* Copies of value list arguments. */
Tcl_Obj *resultList; /* List of result values from the loop body,
* or NULL if we're not collecting them
* ([lmap] vs [foreach]). */
};
|
| ︙ | ︙ | |||
115 116 117 118 119 120 121 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_BreakObjCmd( | | | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_BreakObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
146 147 148 149 150 151 152 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_CatchObjCmd( | | | | 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_CatchObjCmd(
void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRCatchObjCmd, clientData, objc, objv);
}
int
TclNRCatchObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *varNamePtr = NULL;
Tcl_Obj *optionVarNamePtr = NULL;
Interp *iPtr = (Interp *) interp;
|
| ︙ | ︙ | |||
190 191 192 193 194 195 196 |
*/
return TclNREvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
}
static int
CatchObjCmdCallback(
| | | 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 |
*/
return TclNREvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
}
static int
CatchObjCmdCallback(
void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
int objc = PTR2INT(data[0]);
Tcl_Obj *varNamePtr = (Tcl_Obj *)data[1];
Tcl_Obj *optionVarNamePtr = (Tcl_Obj *)data[2];
|
| ︙ | ︙ | |||
251 252 253 254 255 256 257 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_CdObjCmd( | | > | > > | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_CdObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *dir;
int result;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?dirName?");
return TCL_ERROR;
}
if (objc == 2) {
dir = objv[1];
} else {
dir = TclGetHomeDirObj(interp, NULL);
if (dir == NULL) {
return TCL_ERROR;
}
Tcl_IncrRefCount(dir);
}
if (Tcl_FSConvertToPathType(interp, dir) != TCL_OK) {
result = TCL_ERROR;
} else {
result = Tcl_FSChdir(dir);
if (result != TCL_OK) {
|
| ︙ | ︙ | |||
306 307 308 309 310 311 312 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_ConcatObjCmd( | | | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ConcatObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc >= 2) {
Tcl_SetObjResult(interp, Tcl_ConcatObj(objc-1, objv+1));
}
|
| ︙ | ︙ | |||
340 341 342 343 344 345 346 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_ContinueObjCmd( | | | 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ContinueObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
400 401 402 403 404 405 406 | * A standard Tcl result. * *---------------------------------------------------------------------- */ int EncodingConvertfromObjCmd( | | > > > > > > > > > > > | > > > > > | > > > > > > > > | | | < > | < < < | < | > > | < > > > > > | | | | | | | | > > > > > | 403 404 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 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 |
* A standard Tcl result.
*
*----------------------------------------------------------------------
*/
int
EncodingConvertfromObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *data; /* Byte array to convert */
Tcl_DString ds; /* Buffer to hold the string */
Tcl_Encoding encoding; /* Encoding to use */
size_t length = 0; /* Length of the byte array being converted */
const char *bytesPtr; /* Pointer to the first byte of the array */
int flags = 0;
size_t result;
Tcl_Obj *failVarObj = NULL;
/*
* Decode parameters:
* Possible combinations:
* 1) data -> objc = 2
* 2) encoding data -> objc = 3
* 3) -nocomplain data -> objc = 3
* 4) -nocomplain encoding data -> objc = 4
* 5) -failindex val data -> objc = 4
* 6) -failindex val encoding data -> objc = 5
*/
if (objc == 2) {
encoding = Tcl_GetEncoding(interp, NULL);
data = objv[1];
} else if (objc > 2 && objc < 6) {
int objcUnprocessed = objc;
data = objv[objc - 1];
bytesPtr = Tcl_GetString(objv[1]);
if (bytesPtr[0] == '-' && bytesPtr[1] == 'n'
&& !strncmp(bytesPtr, "-nocomplain", strlen(bytesPtr))) {
flags = TCL_ENCODING_NOCOMPLAIN;
objcUnprocessed--;
} else if (bytesPtr[0] == '-' && bytesPtr[1] == 'f'
&& !strncmp(bytesPtr, "-failindex", strlen(bytesPtr))) {
/* at least two additional arguments needed */
if (objc < 4) {
goto encConvFromError;
}
failVarObj = objv[2];
flags = TCL_ENCODING_STOPONERROR;
objcUnprocessed -= 2;
}
switch (objcUnprocessed) {
case 3:
if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) {
return TCL_ERROR;
}
break;
case 2:
encoding = Tcl_GetEncoding(interp, NULL);
break;
default:
goto encConvFromError;
}
} else {
encConvFromError:
Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-failindex var? ?encoding? data");
return TCL_ERROR;
}
/*
* Convert the string into a byte array in 'ds'
*/
bytesPtr = (char *) Tcl_GetBytesFromObj(interp, data, &length);
if (bytesPtr == NULL) {
return TCL_ERROR;
}
result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length,
flags, &ds);
if (!(flags & TCL_ENCODING_NOCOMPLAIN) && (result != TCL_INDEX_NONE)) {
if (failVarObj != NULL) {
if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(result), TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
} else {
char buf[TCL_INTEGER_SPACE];
sprintf(buf, "%" TCL_Z_MODIFIER "u", result);
Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte sequence starting at index %"
TCL_Z_MODIFIER "u: '\\x%X'", result, UCHAR(bytesPtr[result])));
Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE",
buf, NULL);
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
} else if (failVarObj != NULL) {
if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(-1), TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
}
/*
* Note that we cannot use Tcl_DStringResult here because it will
* truncate the string at the first null byte.
*/
|
| ︙ | ︙ | |||
494 495 496 497 498 499 500 | * A standard Tcl result. * *---------------------------------------------------------------------- */ int EncodingConverttoObjCmd( | | > > > > > > > > > > > > | > > > > > | > > > > > > > > | | | < > | < < < | < | > > | < > > > > > > | | | | | | | | | | | > > > > > | 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 577 578 579 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 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 |
* A standard Tcl result.
*
*----------------------------------------------------------------------
*/
int
EncodingConverttoObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *data; /* String to convert */
Tcl_DString ds; /* Buffer to hold the byte array */
Tcl_Encoding encoding; /* Encoding to use */
size_t length; /* Length of the string being converted */
const char *stringPtr; /* Pointer to the first byte of the string */
size_t result;
int flags = 0;
Tcl_Obj *failVarObj = NULL;
/*
* Decode parameters:
* Possible combinations:
* 1) data -> objc = 2
* 2) encoding data -> objc = 3
* 3) -nocomplain data -> objc = 3
* 4) -nocomplain encoding data -> objc = 4
* 5) -failindex val data -> objc = 4
* 6) -failindex val encoding data -> objc = 5
*/
if (objc == 2) {
encoding = Tcl_GetEncoding(interp, NULL);
data = objv[1];
} else if (objc > 2 && objc < 6) {
int objcUnprocessed = objc;
data = objv[objc - 1];
stringPtr = Tcl_GetString(objv[1]);
if (stringPtr[0] == '-' && stringPtr[1] == 'n'
&& !strncmp(stringPtr, "-nocomplain", strlen(stringPtr))) {
flags = TCL_ENCODING_NOCOMPLAIN;
objcUnprocessed--;
} else if (stringPtr[0] == '-' && stringPtr[1] == 'f'
&& !strncmp(stringPtr, "-failindex", strlen(stringPtr))) {
/* at least two additional arguments needed */
if (objc < 4) {
goto encConvToError;
}
failVarObj = objv[2];
flags = TCL_ENCODING_STOPONERROR;
objcUnprocessed -= 2;
}
switch (objcUnprocessed) {
case 3:
if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) {
return TCL_ERROR;
}
break;
case 2:
encoding = Tcl_GetEncoding(interp, NULL);
break;
default:
goto encConvToError;
}
} else {
encConvToError:
Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-failindex var? ?encoding? data");
return TCL_ERROR;
}
/*
* Convert the string to a byte array in 'ds'
*/
stringPtr = Tcl_GetStringFromObj(data, &length);
result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length,
flags, &ds);
if (!(flags & TCL_ENCODING_NOCOMPLAIN) && (result != TCL_INDEX_NONE)) {
if (failVarObj != NULL) {
/* I hope, wide int will cover size_t data type */
if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(result), TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
} else {
size_t pos = Tcl_NumUtfChars(stringPtr, result);
int ucs4;
char buf[TCL_INTEGER_SPACE];
TclUtfToUCS4(&stringPtr[result], &ucs4);
sprintf(buf, "%" TCL_Z_MODIFIER "u", result);
Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected character at index %"
TCL_Z_MODIFIER "u: 'U+%06X'", pos, ucs4));
Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE",
buf, NULL);
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
} else if (failVarObj != NULL) {
if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(-1), TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp,
Tcl_NewByteArrayObj((unsigned char*) Tcl_DStringValue(&ds),
Tcl_DStringLength(&ds)));
Tcl_DStringFree(&ds);
/*
|
| ︙ | ︙ | |||
588 589 590 591 592 593 594 | * Can set the encoding search path. * *---------------------------------------------------------------------- */ int EncodingDirsObjCmd( | | | 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 |
* Can set the encoding search path.
*
*----------------------------------------------------------------------
*/
int
EncodingDirsObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *dirListObj;
if (objc > 2) {
|
| ︙ | ︙ | |||
632 633 634 635 636 637 638 | * Returns a standard Tcl result * *----------------------------------------------------------------------------- */ int EncodingNamesObjCmd( | | | 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 |
* Returns a standard Tcl result
*
*-----------------------------------------------------------------------------
*/
int
EncodingNamesObjCmd(
TCL_UNUSED(void *),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Number of command line args */
Tcl_Obj* const objv[]) /* Vector of command line args */
{
if (objc > 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
663 664 665 666 667 668 669 | * May change the system encoding. * *----------------------------------------------------------------------------- */ int EncodingSystemObjCmd( | | | 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 |
* May change the system encoding.
*
*-----------------------------------------------------------------------------
*/
int
EncodingSystemObjCmd(
TCL_UNUSED(void *),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Number of command line args */
Tcl_Obj* const objv[]) /* Vector of command line args */
{
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?encoding?");
return TCL_ERROR;
|
| ︙ | ︙ | |||
700 701 702 703 704 705 706 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_ErrorObjCmd( | | | 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ErrorObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *options, *optName;
if ((objc < 2) || (objc > 4)) {
|
| ︙ | ︙ | |||
749 750 751 752 753 754 755 | * See the user documentation. * *---------------------------------------------------------------------- */ static int EvalCmdErrMsg( | | | | | 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
EvalCmdErrMsg(
TCL_UNUSED(void **),
Tcl_Interp *interp,
int result)
{
if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (\"eval\" body line %d)", Tcl_GetErrorLine(interp)));
}
return result;
}
int
Tcl_EvalObjCmd(
void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNREvalObjCmd, clientData, objc, objv);
}
int
TclNREvalObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *objPtr;
Interp *iPtr = (Interp *) interp;
CmdFrame *invoker = NULL;
|
| ︙ | ︙ | |||
831 832 833 834 835 836 837 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_ExitObjCmd( | | | 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ExitObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_WideInt value;
if ((objc != 1) && (objc != 2)) {
|
| ︙ | ︙ | |||
878 879 880 881 882 883 884 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_ExprObjCmd( | | | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ExprObjCmd(
void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRExprObjCmd, clientData, objc, objv);
}
int
TclNRExprObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *resultPtr, *objPtr;
if (objc < 2) {
|
| ︙ | ︙ | |||
915 916 917 918 919 920 921 |
}
return Tcl_NRExprObj(interp, objPtr, resultPtr);
}
static int
ExprCallback(
| | | 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 |
}
return Tcl_NRExprObj(interp, objPtr, resultPtr);
}
static int
ExprCallback(
void *data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj *resultPtr = (Tcl_Obj *)data[0];
Tcl_Obj *objPtr = (Tcl_Obj *)data[1];
if (objPtr != NULL) {
|
| ︙ | ︙ | |||
974 975 976 977 978 979 980 981 982 983 984 985 986 987 |
{"channels", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"copy", TclFileCopyCmd, NULL, NULL, NULL, 1},
{"delete", TclFileDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1},
{"dirname", PathDirNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"join", PathJoinCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"link", TclFileLinkCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 1},
{"lstat", FileAttrLinkStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 1},
{"mtime", FileAttrModifyTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 1},
{"mkdir", TclFileMakeDirsCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1},
| > | 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 |
{"channels", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"copy", TclFileCopyCmd, NULL, NULL, NULL, 1},
{"delete", TclFileDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1},
{"dirname", PathDirNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"home", TclFileHomeCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
{"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"join", PathJoinCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"link", TclFileLinkCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 1},
{"lstat", FileAttrLinkStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 1},
{"mtime", FileAttrModifyTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 1},
{"mkdir", TclFileMakeDirsCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1},
|
| ︙ | ︙ | |||
997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 |
{"size", FileAttrSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"split", PathSplitCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 1},
{"system", PathFilesystemCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"tempdir", TclFileTempDirCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
{"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 1},
{"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1},
{"writable", FileAttrIsWritableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{NULL, NULL, NULL, NULL, NULL, 0}
};
return TclMakeEnsemble(interp, "file", initMap);
}
| > | 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 |
{"size", FileAttrSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"split", PathSplitCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 1},
{"system", PathFilesystemCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"tempdir", TclFileTempDirCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
{"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 1},
{"tildeexpand", TclFileTildeExpandCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1},
{"writable", FileAttrIsWritableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{NULL, NULL, NULL, NULL, NULL, 0}
};
return TclMakeEnsemble(interp, "file", initMap);
}
|
| ︙ | ︙ | |||
1024 1025 1026 1027 1028 1029 1030 | * May update the access time on the file, if requested by the user. * *---------------------------------------------------------------------- */ static int FileAttrAccessTimeCmd( | | | 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 |
* May update the access time on the file, if requested by the user.
*
*----------------------------------------------------------------------
*/
static int
FileAttrAccessTimeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
struct utimbuf tval;
|
| ︙ | ︙ | |||
1106 1107 1108 1109 1110 1111 1112 | * user. * *---------------------------------------------------------------------- */ static int FileAttrModifyTimeCmd( | | | 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 |
* user.
*
*----------------------------------------------------------------------
*/
static int
FileAttrModifyTimeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
struct utimbuf tval;
|
| ︙ | ︙ | |||
1185 1186 1187 1188 1189 1190 1191 | * Writes to an array named by the user. * *---------------------------------------------------------------------- */ static int FileAttrLinkStatCmd( | | | 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 |
* Writes to an array named by the user.
*
*----------------------------------------------------------------------
*/
static int
FileAttrLinkStatCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
if (objc != 3) {
|
| ︙ | ︙ | |||
1221 1222 1223 1224 1225 1226 1227 | * Writes to an array named by the user. * *---------------------------------------------------------------------- */ static int FileAttrStatCmd( | | | 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 |
* Writes to an array named by the user.
*
*----------------------------------------------------------------------
*/
static int
FileAttrStatCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
if (objc != 3) {
|
| ︙ | ︙ | |||
1257 1258 1259 1260 1261 1262 1263 | * None. * *---------------------------------------------------------------------- */ static int FileAttrTypeCmd( | | | 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrTypeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
if (objc != 2) {
|
| ︙ | ︙ | |||
1295 1296 1297 1298 1299 1300 1301 | * None. * *---------------------------------------------------------------------- */ static int FileAttrSizeCmd( | | | 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrSizeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
if (objc != 2) {
|
| ︙ | ︙ | |||
1332 1333 1334 1335 1336 1337 1338 | * None. * *---------------------------------------------------------------------- */ static int FileAttrIsDirectoryCmd( | | | 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrIsDirectoryCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
int value = 0;
|
| ︙ | ︙ | |||
1370 1371 1372 1373 1374 1375 1376 | * None. * *---------------------------------------------------------------------- */ static int FileAttrIsExecutableCmd( | | | 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrIsExecutableCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
|
| ︙ | ︙ | |||
1401 1402 1403 1404 1405 1406 1407 | * None. * *---------------------------------------------------------------------- */ static int FileAttrIsExistingCmd( | | | 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrIsExistingCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
|
| ︙ | ︙ | |||
1432 1433 1434 1435 1436 1437 1438 | * None. * *---------------------------------------------------------------------- */ static int FileAttrIsFileCmd( | | | 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrIsFileCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
int value = 0;
|
| ︙ | ︙ | |||
1470 1471 1472 1473 1474 1475 1476 | * None. * *---------------------------------------------------------------------- */ static int FileAttrIsOwnedCmd( | | | 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrIsOwnedCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
#ifdef __CYGWIN__
#define geteuid() (short)(geteuid)()
#endif
|
| ︙ | ︙ | |||
1517 1518 1519 1520 1521 1522 1523 | * None. * *---------------------------------------------------------------------- */ static int FileAttrIsReadableCmd( | | | 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrIsReadableCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
|
| ︙ | ︙ | |||
1548 1549 1550 1551 1552 1553 1554 | * None. * *---------------------------------------------------------------------- */ static int FileAttrIsWritableCmd( | | | 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrIsWritableCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
|
| ︙ | ︙ | |||
1579 1580 1581 1582 1583 1584 1585 | * None. * *---------------------------------------------------------------------- */ static int PathDirNameCmd( | | | 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathDirNameCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *dirPtr;
if (objc != 2) {
|
| ︙ | ︙ | |||
1618 1619 1620 1621 1622 1623 1624 | * None. * *---------------------------------------------------------------------- */ static int PathExtensionCmd( | | | 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathExtensionCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *dirPtr;
if (objc != 2) {
|
| ︙ | ︙ | |||
1657 1658 1659 1660 1661 1662 1663 | * None. * *---------------------------------------------------------------------- */ static int PathRootNameCmd( | | | 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathRootNameCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *dirPtr;
if (objc != 2) {
|
| ︙ | ︙ | |||
1696 1697 1698 1699 1700 1701 1702 | * None. * *---------------------------------------------------------------------- */ static int PathTailCmd( | | | 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathTailCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *dirPtr;
if (objc != 2) {
|
| ︙ | ︙ | |||
1735 1736 1737 1738 1739 1740 1741 | * None. * *---------------------------------------------------------------------- */ static int PathFilesystemCmd( | | | 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathFilesystemCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *fsInfo;
if (objc != 2) {
|
| ︙ | ︙ | |||
1776 1777 1778 1779 1780 1781 1782 | * None. * *---------------------------------------------------------------------- */ static int PathJoinCmd( | | | 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathJoinCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
return TCL_ERROR;
|
| ︙ | ︙ | |||
1808 1809 1810 1811 1812 1813 1814 | * None. * *---------------------------------------------------------------------- */ static int PathNativeNameCmd( | | | 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathNativeNameCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_DString ds;
if (objc != 2) {
|
| ︙ | ︙ | |||
1845 1846 1847 1848 1849 1850 1851 | * None. * *---------------------------------------------------------------------- */ static int PathNormalizeCmd( | | | 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathNormalizeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *fileName;
if (objc != 2) {
|
| ︙ | ︙ | |||
1883 1884 1885 1886 1887 1888 1889 | * None. * *---------------------------------------------------------------------- */ static int PathSplitCmd( | | | | 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathSplitCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *res;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
res = Tcl_FSSplitPath(objv[1], (size_t *)NULL);
if (res == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": no such file or directory",
TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PATHSPLIT", "NONESUCH",
NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
1926 1927 1928 1929 1930 1931 1932 | * None. * *---------------------------------------------------------------------- */ static int PathTypeCmd( | | | 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathTypeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *typeName;
if (objc != 2) {
|
| ︙ | ︙ | |||
1974 1975 1976 1977 1978 1979 1980 | * None. * *---------------------------------------------------------------------- */ static int FilesystemSeparatorCmd( | | | 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FilesystemSeparatorCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc < 1 || objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?name?");
return TCL_ERROR;
|
| ︙ | ︙ | |||
2029 2030 2031 2032 2033 2034 2035 | * None. * *---------------------------------------------------------------------- */ static int FilesystemVolumesCmd( | | | 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FilesystemVolumesCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
2182 2183 2184 2185 2186 2187 2188 |
/*
* Watch out porters; the inode is meant to be an *unsigned* value, so the
* cast might fail when there isn't a real arithmetic 'long long' type...
*/
STORE_ARY("dev", Tcl_NewWideIntObj((long)statPtr->st_dev));
| | | | | 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 |
/*
* Watch out porters; the inode is meant to be an *unsigned* value, so the
* cast might fail when there isn't a real arithmetic 'long long' type...
*/
STORE_ARY("dev", Tcl_NewWideIntObj((long)statPtr->st_dev));
STORE_ARY("ino", Tcl_NewWideIntObj(statPtr->st_ino));
STORE_ARY("nlink", Tcl_NewWideIntObj((long)statPtr->st_nlink));
STORE_ARY("uid", Tcl_NewWideIntObj((long)statPtr->st_uid));
STORE_ARY("gid", Tcl_NewWideIntObj((long)statPtr->st_gid));
STORE_ARY("size", Tcl_NewWideIntObj(statPtr->st_size));
#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
STORE_ARY("blocks", Tcl_NewWideIntObj(statPtr->st_blocks));
#endif
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
STORE_ARY("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize));
#endif
STORE_ARY("atime", Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr)));
STORE_ARY("mtime", Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(statPtr)));
STORE_ARY("ctime", Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr)));
|
| ︙ | ︙ | |||
2289 2290 2291 2292 2293 2294 2295 | * |____________________| * *---------------------------------------------------------------------- */ int Tcl_ForObjCmd( | | | | 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 |
* |____________________|
*
*----------------------------------------------------------------------
*/
int
Tcl_ForObjCmd(
void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRForObjCmd, clientData, objc, objv);
}
int
TclNRForObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
ForIterData *iterPtr;
|
| ︙ | ︙ | |||
2330 2331 2332 2333 2334 2335 2336 |
*/
return TclNREvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
}
static int
ForSetupCallback(
| | | | 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 2424 2425 2426 2427 2428 2429 2430 2431 2432 |
*/
return TclNREvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
}
static int
ForSetupCallback(
void *data[],
Tcl_Interp *interp,
int result)
{
ForIterData *iterPtr = (ForIterData *)data[0];
if (result != TCL_OK) {
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)");
}
TclSmallFreeEx(interp, iterPtr);
return result;
}
TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL);
return TCL_OK;
}
int
TclNRForIterCallback(
void *data[],
Tcl_Interp *interp,
int result)
{
ForIterData *iterPtr = (ForIterData *)data[0];
Tcl_Obj *boolObj;
switch (result) {
|
| ︙ | ︙ | |||
2384 2385 2386 2387 2388 2389 2390 |
}
TclSmallFreeEx(interp, iterPtr);
return result;
}
static int
ForCondCallback(
| | | 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 |
}
TclSmallFreeEx(interp, iterPtr);
return result;
}
static int
ForCondCallback(
void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
ForIterData *iterPtr = (ForIterData *)data[0];
Tcl_Obj *boolObj = (Tcl_Obj *)data[1];
int value;
|
| ︙ | ︙ | |||
2422 2423 2424 2425 2426 2427 2428 |
}
TclSmallFreeEx(interp, iterPtr);
return result;
}
static int
ForNextCallback(
| | | 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 |
}
TclSmallFreeEx(interp, iterPtr);
return result;
}
static int
ForNextCallback(
void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
ForIterData *iterPtr = (ForIterData *)data[0];
Tcl_Obj *next = iterPtr->next;
|
| ︙ | ︙ | |||
2447 2448 2449 2450 2451 2452 2453 |
TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL);
return result;
}
static int
ForPostNextCallback(
| | | 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 |
TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL);
return result;
}
static int
ForPostNextCallback(
void *data[],
Tcl_Interp *interp,
int result)
{
ForIterData *iterPtr = (ForIterData *)data[0];
if ((result != TCL_BREAK) && (result != TCL_OK)) {
if (result == TCL_ERROR) {
|
| ︙ | ︙ | |||
2483 2484 2485 2486 2487 2488 2489 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_ForeachObjCmd( | | | | | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ForeachObjCmd(
void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRForeachCmd, clientData, objc, objv);
}
int
TclNRForeachCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
return EachloopCmd(interp, TCL_EACH_KEEP_NONE, objc, objv);
}
int
Tcl_LmapObjCmd(
void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRLmapCmd, clientData, objc, objv);
}
int
TclNRLmapCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
return EachloopCmd(interp, TCL_EACH_COLLECT, objc, objv);
}
|
| ︙ | ︙ | |||
2556 2557 2558 2559 2560 2561 2562 |
*
* The setting up of all of these pointers is moderately messy, but allows
* the rest of this code to be simple and for us to use a single memory
* allocation for better performance.
*/
statePtr = (struct ForeachState *)TclStackAlloc(interp,
| | | | | 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 |
*
* The setting up of all of these pointers is moderately messy, but allows
* the rest of this code to be simple and for us to use a single memory
* allocation for better performance.
*/
statePtr = (struct ForeachState *)TclStackAlloc(interp,
sizeof(struct ForeachState) + 3 * numLists * sizeof(size_t)
+ 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *)));
memset(statePtr, 0,
sizeof(struct ForeachState) + 3 * numLists * sizeof(size_t)
+ 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *)));
statePtr->varvList = (Tcl_Obj ***) (statePtr + 1);
statePtr->argvList = statePtr->varvList + numLists;
statePtr->vCopyList = (Tcl_Obj **) (statePtr->argvList + numLists);
statePtr->aCopyList = statePtr->vCopyList + numLists;
statePtr->index = (size_t *) (statePtr->aCopyList + numLists);
statePtr->varcList = statePtr->index + numLists;
statePtr->argcList = statePtr->varcList + numLists;
statePtr->numLists = numLists;
statePtr->bodyPtr = objv[objc - 1];
statePtr->bodyIdx = objc - 1;
|
| ︙ | ︙ | |||
2589 2590 2591 2592 2593 2594 2595 |
for (i=0 ; i<numLists ; i++) {
statePtr->vCopyList[i] = TclListObjCopy(interp, objv[1+i*2]);
if (statePtr->vCopyList[i] == NULL) {
result = TCL_ERROR;
goto done;
}
| | | | 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 |
for (i=0 ; i<numLists ; i++) {
statePtr->vCopyList[i] = TclListObjCopy(interp, objv[1+i*2]);
if (statePtr->vCopyList[i] == NULL) {
result = TCL_ERROR;
goto done;
}
TclListObjGetElementsM(NULL, statePtr->vCopyList[i],
&statePtr->varcList[i], &statePtr->varvList[i]);
if (statePtr->varcList[i] < 1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s varlist is empty",
(statePtr->resultList != NULL ? "lmap" : "foreach")));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
(statePtr->resultList != NULL ? "LMAP" : "FOREACH"),
"NEEDVARS", NULL);
result = TCL_ERROR;
goto done;
}
statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]);
if (statePtr->aCopyList[i] == NULL) {
result = TCL_ERROR;
goto done;
}
TclListObjGetElementsM(NULL, statePtr->aCopyList[i],
&statePtr->argcList[i], &statePtr->argvList[i]);
j = statePtr->argcList[i] / statePtr->varcList[i];
if ((statePtr->argcList[i] % statePtr->varcList[i]) != 0) {
j++;
}
if (j > statePtr->maxj) {
|
| ︙ | ︙ | |||
2652 2653 2654 2655 2656 2657 2658 | /* * Post-body processing handler. */ static int ForeachLoopStep( | | | 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 |
/*
* Post-body processing handler.
*/
static int
ForeachLoopStep(
void *data[],
Tcl_Interp *interp,
int result)
{
struct ForeachState *statePtr = (struct ForeachState *)data[0];
/*
* Process the result code from this run of the [foreach] body. Note that
|
| ︙ | ︙ | |||
2727 2728 2729 2730 2731 2732 2733 |
*/
static inline int
ForeachAssignments(
Tcl_Interp *interp,
struct ForeachState *statePtr)
{
| | > | 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 |
*/
static inline int
ForeachAssignments(
Tcl_Interp *interp,
struct ForeachState *statePtr)
{
int i;
size_t v, k;
Tcl_Obj *valuePtr, *varValuePtr;
for (i=0 ; i<statePtr->numLists ; i++) {
for (v=0 ; v<statePtr->varcList[i] ; v++) {
k = statePtr->index[i]++;
if (k < statePtr->argcList[i]) {
|
| ︙ | ︙ | |||
2800 2801 2802 2803 2804 2805 2806 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_FormatObjCmd( | | | 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_FormatObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *resultPtr; /* Where result is stored finally. */
if (objc < 2) {
|
| ︙ | ︙ |
Changes to generic/tclCmdIL.c.
| ︙ | ︙ | |||
66 67 68 69 70 71 72 |
int *indexv; /* If the -index option was specified, this
* holds an encoding of the indexes contained
* in the list supplied as an argument to
* that option.
* NULL if no indexes supplied, and points to
* singleIndex field when only one
* supplied. */
| | | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 |
int *indexv; /* If the -index option was specified, this
* holds an encoding of the indexes contained
* in the list supplied as an argument to
* that option.
* NULL if no indexes supplied, and points to
* singleIndex field when only one
* supplied. */
size_t indexc; /* Number of indexes in indexv array. */
int singleIndex; /* Static space for common index case. */
int unique;
int numElements;
Tcl_Interp *interp; /* The interpreter in which the sort is being
* done. */
int resultCode; /* Completion code for the lsort command. If
* an error occurs during the sort this is
|
| ︙ | ︙ | |||
181 182 183 184 185 186 187 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_IfObjCmd( | | | | 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_IfObjCmd(
void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRIfObjCmd, clientData, objc, objv);
}
int
TclNRIfObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *boolObj;
if (objc <= 1) {
|
| ︙ | ︙ | |||
214 215 216 217 218 219 220 |
* At this point, objv[1] refers to the main expression to test. The
* arguments after the expression must be "then" (optional) and a script
* to execute if the expression is true.
*/
TclNewObj(boolObj);
Tcl_NRAddCallback(interp, IfConditionCallback, INT2PTR(objc),
| | | | 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 |
* At this point, objv[1] refers to the main expression to test. The
* arguments after the expression must be "then" (optional) and a script
* to execute if the expression is true.
*/
TclNewObj(boolObj);
Tcl_NRAddCallback(interp, IfConditionCallback, INT2PTR(objc),
(void *) objv, INT2PTR(1), boolObj);
return Tcl_NRExprObj(interp, objv[1], boolObj);
}
static int
IfConditionCallback(
void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
int objc = PTR2INT(data[0]);
Tcl_Obj *const *objv = (Tcl_Obj *const *)data[1];
int i = PTR2INT(data[2]);
|
| ︙ | ︙ | |||
364 365 366 367 368 369 370 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_IncrObjCmd( | | | 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_IncrObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *newValuePtr, *incrPtr;
if ((objc != 2) && (objc != 3)) {
|
| ︙ | ︙ | |||
445 446 447 448 449 450 451 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoArgsCmd( | | | 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoArgsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
const char *name;
Proc *procPtr;
|
| ︙ | ︙ | |||
508 509 510 511 512 513 514 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoBodyCmd( | | | 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoBodyCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
const char *name, *bytes;
Proc *procPtr;
|
| ︙ | ︙ | |||
569 570 571 572 573 574 575 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoCmdCountCmd( | | | 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoCmdCountCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
if (objc != 1) {
|
| ︙ | ︙ | |||
611 612 613 614 615 616 617 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoCommandsCmd( | | | 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoCommandsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *cmdName, *pattern;
const char *simplePattern;
Tcl_HashEntry *entryPtr;
|
| ︙ | ︙ | |||
888 889 890 891 892 893 894 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoCompleteCmd( | | | 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoCompleteCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "command");
return TCL_ERROR;
|
| ︙ | ︙ | |||
925 926 927 928 929 930 931 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoDefaultCmd( | | | 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoDefaultCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
const char *procName, *argName;
Proc *procPtr;
|
| ︙ | ︙ | |||
1007 1008 1009 1010 1011 1012 1013 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoErrorStackCmd( | | | 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoErrorStackCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Interp *target;
Interp *iPtr;
|
| ︙ | ︙ | |||
1056 1057 1058 1059 1060 1061 1062 | * error, the result is an error message. * *---------------------------------------------------------------------- */ int TclInfoExistsCmd( | | | 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
int
TclInfoExistsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *varName;
Var *varPtr;
|
| ︙ | ︙ | |||
1101 1102 1103 1104 1105 1106 1107 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoFrameCmd( | | | 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoFrameCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
int level, code = TCL_OK;
CmdFrame *framePtr, **cmdFramePtrPtr = &iPtr->cmdFramePtr;
|
| ︙ | ︙ | |||
1441 1442 1443 1444 1445 1446 1447 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoFunctionsCmd( | | | 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoFunctionsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *script;
int code;
|
| ︙ | ︙ | |||
1506 1507 1508 1509 1510 1511 1512 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoHostnameCmd( | | | 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoHostnameCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *name;
if (objc != 1) {
|
| ︙ | ︙ | |||
1552 1553 1554 1555 1556 1557 1558 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoLevelCmd( | | | | | 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoLevelCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
if (objc == 1) { /* Just "info level" */
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((int)iPtr->varFramePtr->level));
return TCL_OK;
}
if (objc == 2) {
int level;
CallFrame *framePtr, *rootFramePtr = iPtr->rootFramePtr;
if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) {
return TCL_ERROR;
}
if (level <= 0) {
if (iPtr->varFramePtr == rootFramePtr) {
goto levelError;
}
level += iPtr->varFramePtr->level;
}
for (framePtr=iPtr->varFramePtr ; framePtr!=rootFramePtr;
framePtr=framePtr->callerVarPtr) {
if ((int)framePtr->level == level) {
break;
}
}
if (framePtr == rootFramePtr) {
goto levelError;
}
|
| ︙ | ︙ | |||
1626 1627 1628 1629 1630 1631 1632 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoLibraryCmd( | | | 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoLibraryCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *libDirName;
if (objc != 1) {
|
| ︙ | ︙ | |||
1673 1674 1675 1676 1677 1678 1679 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoLoadedCmd( | | | 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoLoadedCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *interpName, *packageName;
if (objc > 3) {
|
| ︙ | ︙ | |||
1721 1722 1723 1724 1725 1726 1727 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoNameOfExecutableCmd( | | | 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoNameOfExecutableCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
1757 1758 1759 1760 1761 1762 1763 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoPatchLevelCmd( | | | 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoPatchLevelCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *patchlevel;
if (objc != 1) {
|
| ︙ | ︙ | |||
1804 1805 1806 1807 1808 1809 1810 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoProcsCmd( | | | 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoProcsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *cmdName, *pattern;
const char *simplePattern;
Namespace *nsPtr;
|
| ︙ | ︙ | |||
1991 1992 1993 1994 1995 1996 1997 | * script filename. * *---------------------------------------------------------------------- */ static int InfoScriptCmd( | | | 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 |
* script filename.
*
*----------------------------------------------------------------------
*/
static int
InfoScriptCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
if ((objc != 1) && (objc != 2)) {
|
| ︙ | ︙ | |||
2039 2040 2041 2042 2043 2044 2045 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoSharedlibCmd( | | | 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoSharedlibCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
2077 2078 2079 2080 2081 2082 2083 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoTclVersionCmd( | | | 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoTclVersionCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *version;
if (objc != 1) {
|
| ︙ | ︙ | |||
2120 2121 2122 2123 2124 2125 2126 | * message. * *---------------------------------------------------------------------- */ static int InfoCmdTypeCmd( | | | 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 |
* message.
*
*----------------------------------------------------------------------
*/
static int
InfoCmdTypeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Command command;
if (objc != 2) {
|
| ︙ | ︙ | |||
2171 2172 2173 2174 2175 2176 2177 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_JoinObjCmd( | | | < | | 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_JoinObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
size_t length, listLen;
Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs;
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
return TCL_ERROR;
}
/*
* Make sure the list argument is a list object and get its length and a
* pointer to its array of element pointers.
*/
if (TclListObjGetElementsM(interp, objv[1], &listLen,
&elemPtrs) != TCL_OK) {
return TCL_ERROR;
}
if (listLen == 0) {
/* No elements to join; default empty result is correct. */
return TCL_OK;
|
| ︙ | ︙ | |||
2212 2213 2214 2215 2216 2217 2218 |
joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2];
Tcl_IncrRefCount(joinObjPtr);
(void) Tcl_GetStringFromObj(joinObjPtr, &length);
if (length == 0) {
resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0);
} else {
| | | 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 |
joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2];
Tcl_IncrRefCount(joinObjPtr);
(void) Tcl_GetStringFromObj(joinObjPtr, &length);
if (length == 0) {
resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0);
} else {
size_t i;
resObjPtr = Tcl_NewObj();
for (i = 0; i < listLen; i++) {
if (i > 0) {
/*
* NOTE: This code is relying on Tcl_AppendObjToObj() **NOT**
|
| ︙ | ︙ | |||
2257 2258 2259 2260 2261 2262 2263 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LassignObjCmd( | | | | | 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LassignObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *listCopyPtr;
Tcl_Obj **listObjv; /* The contents of the list. */
size_t listObjc; /* The length of the list. */
int code = TCL_OK;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?varName ...?");
return TCL_ERROR;
}
listCopyPtr = TclListObjCopy(interp, objv[1]);
if (listCopyPtr == NULL) {
return TCL_ERROR;
}
TclListObjGetElementsM(NULL, listCopyPtr, &listObjc, &listObjv);
objc -= 2;
objv += 2;
while (code == TCL_OK && objc > 0 && listObjc > 0) {
if (Tcl_ObjSetVar2(interp, *objv++, NULL, *listObjv++,
TCL_LEAVE_ERR_MSG) == NULL) {
code = TCL_ERROR;
|
| ︙ | ︙ | |||
2331 2332 2333 2334 2335 2336 2337 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LindexObjCmd( | | | 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LindexObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *elemPtr; /* Pointer to the element being extracted. */
if (objc < 2) {
|
| ︙ | ︙ | |||
2389 2390 2391 2392 2393 2394 2395 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LinsertObjCmd( | | | | | | | | 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 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LinsertObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *listPtr;
size_t len, index;
int result;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "list index ?element ...?");
return TCL_ERROR;
}
result = TclListObjLengthM(interp, objv[1], &len);
if (result != TCL_OK) {
return result;
}
/*
* Get the index. "end" is interpreted to be the index after the last
* element, such that using it will cause any inserted elements to be
* appended to the list.
*/
result = TclGetIntForIndexM(interp, objv[2], /*end*/ len, &index);
if (result != TCL_OK) {
return result;
}
if (index + 1 > len + 1) {
index = len;
}
/*
* If the list object is unshared we can modify it directly. Otherwise we
* create a copy to modify: this is "copy on write".
*/
listPtr = objv[1];
if (Tcl_IsShared(listPtr)) {
listPtr = TclListObjCopy(NULL, listPtr);
}
if ((objc == 4) && (index == len)) {
/*
* Special case: insert one element at the end of the list.
*/
Tcl_ListObjAppendElement(NULL, listPtr, objv[3]);
} else {
if (TCL_OK != Tcl_ListObjReplace(interp, listPtr, index, 0,
|
| ︙ | ︙ | |||
2472 2473 2474 2475 2476 2477 2478 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_ListObjCmd( | | | 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* The argument objects. */
{
/*
* If there are no list elements, the result is an empty object.
|
| ︙ | ︙ | |||
2508 2509 2510 2511 2512 2513 2514 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LlengthObjCmd( | | | > | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LlengthObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* Argument objects. */
{
size_t listLen;
int result;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list");
return TCL_ERROR;
}
result = TclListObjLengthM(interp, objv[1], &listLen);
if (result != TCL_OK) {
return result;
}
/*
* Set the interpreter's object result to an integer object holding the
* length.
|
| ︙ | ︙ | |||
2554 2555 2556 2557 2558 2559 2560 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LpopObjCmd( | | | > | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LpopObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* Argument objects. */
{
size_t listLen;
int result;
Tcl_Obj *elemPtr, *stored;
Tcl_Obj *listPtr, **elemPtrs;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "listvar ?index?");
return TCL_ERROR;
}
listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
if (listPtr == NULL) {
return TCL_ERROR;
}
result = TclListObjGetElementsM(interp, listPtr, &listLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
/*
* First, extract the element to be returned.
* TclLindexFlat adds a ref count which is handled.
|
| ︙ | ︙ | |||
2655 2656 2657 2658 2659 2660 2661 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LrangeObjCmd( | | | | | | 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 2681 2682 2683 2684 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LrangeObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* Argument objects. */
{
int result;
size_t listLen, first, last;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "list first last");
return TCL_ERROR;
}
result = TclListObjLengthM(interp, objv[1], &listLen);
if (result != TCL_OK) {
return result;
}
result = TclGetIntForIndexM(interp, objv[2], /*endValue*/ listLen - 1,
&first);
if (result != TCL_OK) {
|
| ︙ | ︙ | |||
2724 2725 2726 2727 2728 2729 2730 |
*/
return (idx1 < idx2) ? 1 : (idx1 > idx2) ? -1 : 0;
}
int
Tcl_LremoveObjCmd(
| | | | | | 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 |
*/
return (idx1 < idx2) ? 1 : (idx1 > idx2) ? -1 : 0;
}
int
Tcl_LremoveObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, idxc, prevIdx, first, num;
size_t *idxv, listLen;
Tcl_Obj *listObj;
/*
* Parse the arguments.
*/
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?");
return TCL_ERROR;
}
listObj = objv[1];
if (TclListObjLengthM(interp, listObj, &listLen) != TCL_OK) {
return TCL_ERROR;
}
idxc = objc - 2;
if (idxc == 0) {
Tcl_SetObjResult(interp, listObj);
return TCL_OK;
|
| ︙ | ︙ | |||
2790 2791 2792 2793 2794 2795 2796 |
* Repeated index and sanity check.
*/
if (idx == prevIdx) {
continue;
}
prevIdx = idx;
| | | 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 |
* Repeated index and sanity check.
*/
if (idx == prevIdx) {
continue;
}
prevIdx = idx;
if (idx < 0 || idx >= (int)listLen) {
continue;
}
/*
* Coalesce adjacent removes to reduce the number of copies.
*/
|
| ︙ | ︙ | |||
2843 2844 2845 2846 2847 2848 2849 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LrepeatObjCmd( | | | 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LrepeatObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* The argument objects. */
{
int elementCount, i, totalElems;
Tcl_Obj *listPtr, **dataArray = NULL;
|
| ︙ | ︙ | |||
2881 2882 2883 2884 2885 2886 2887 |
*/
objc -= 2;
objv += 2;
/* Final sanity check. Do not exceed limits on max list length. */
| | | | > > > > > > > | < < | 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 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 |
*/
objc -= 2;
objv += 2;
/* Final sanity check. Do not exceed limits on max list length. */
if (elementCount && (size_t)objc > LIST_MAX/elementCount) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max length of a Tcl list (%" TCL_Z_MODIFIER "u elements) exceeded", LIST_MAX));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
return TCL_ERROR;
}
totalElems = objc * elementCount;
/*
* Get an empty list object that is allocated large enough to hold each
* init value elementCount times.
*/
listPtr = Tcl_NewListObj(totalElems, NULL);
if (totalElems) {
ListRep listRep;
ListObjGetRep(listPtr, &listRep);
dataArray = ListRepElementsBase(&listRep);
listRep.storePtr->numUsed = totalElems;
if (listRep.spanPtr) {
/* Future proofing in case Tcl_NewListObj returns a span */
listRep.spanPtr->spanStart = listRep.storePtr->firstUsed;
listRep.spanPtr->spanLength = listRep.storePtr->numUsed;
}
}
/*
* Set the elements. Note that we handle the common degenerate case of a
* single value being repeated separately to permit the compiler as much
* room as possible to optimize a loop that might be run a very large
* number of times.
|
| ︙ | ︙ | |||
2952 2953 2954 2955 2956 2957 2958 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LreplaceObjCmd( | | | | | | 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LreplaceObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *listPtr;
ssize_t first, last, numToDelete, listLen;
int result;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"list first last ?element ...?");
return TCL_ERROR;
}
result = TclListObjLengthM(interp, objv[1], &listLen);
if (result != TCL_OK) {
return result;
}
/*
* Get the first and last indexes. "end" is interpreted to be the index
* for the last element, such that using it will cause that element to be
|
| ︙ | ︙ | |||
3053 3054 3055 3056 3057 3058 3059 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LreverseObjCmd( | | | | | | | > > | | > > > > > | 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LreverseObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
Tcl_Obj **elemv;
size_t elemc, i, j;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list");
return TCL_ERROR;
}
if (TclListObjGetElementsM(interp, objv[1], &elemc, &elemv) != TCL_OK) {
return TCL_ERROR;
}
/*
* If the list is empty, just return it. [Bug 1876793]
*/
if (!elemc) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
if (Tcl_IsShared(objv[1])
|| ListObjRepIsShared(objv[1])) { /* Bug 1675044 */
Tcl_Obj *resultObj, **dataArray;
ListRep listRep;
resultObj = Tcl_NewListObj(elemc, NULL);
/* Modify the internal rep in-place */
ListObjGetRep(resultObj, &listRep);
listRep.storePtr->numUsed = elemc;
dataArray = ListRepElementsBase(&listRep);
if (listRep.spanPtr) {
/* Future proofing */
listRep.spanPtr->spanStart = listRep.storePtr->firstUsed;
listRep.spanPtr->spanLength = listRep.storePtr->numUsed;
}
for (i=0,j=elemc-1 ; i<elemc ; i++,j--) {
dataArray[j] = elemv[i];
Tcl_IncrRefCount(elemv[i]);
}
Tcl_SetObjResult(interp, resultObj);
|
| ︙ | ︙ | |||
3132 3133 3134 3135 3136 3137 3138 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LsearchObjCmd( | | | | | 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LsearchObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
const char *bytes, *patternBytes;
int match, index, result=TCL_OK, bisect;
size_t length = 0, elemLen, groupSize, groupOffset, lower, upper;
ssize_t start, listc, i;
int allocatedIndexVector = 0;
int isIncreasing;
Tcl_WideInt patWide, objWide, wide;
int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase;
double patDouble, objDouble;
SortInfo sortInfo;
Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr;
|
| ︙ | ︙ | |||
3199 3200 3201 3202 3203 3204 3205 |
sortInfo.indexc = 0;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list pattern");
return TCL_ERROR;
}
| | | 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 |
sortInfo.indexc = 0;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list pattern");
return TCL_ERROR;
}
for (i = 1; i < (size_t)objc-2; i++) {
enum lsearchoptions idx;
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &idx)
!= TCL_OK) {
result = TCL_ERROR;
goto done;
}
switch (idx) {
|
| ︙ | ︙ | |||
3269 3270 3271 3272 3273 3274 3275 |
* because it will either be replaced or there will be an error.
*/
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
startPtr = NULL;
}
| | | 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 |
* because it will either be replaced or there will be an error.
*/
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
startPtr = NULL;
}
if (i + 4 > (size_t)objc) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing starting index", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
result = TCL_ERROR;
goto done;
}
i++;
|
| ︙ | ︙ | |||
3292 3293 3294 3295 3296 3297 3298 |
startPtr = Tcl_DuplicateObj(objv[i]);
} else {
startPtr = objv[i];
}
Tcl_IncrRefCount(startPtr);
break;
case LSEARCH_STRIDE: /* -stride */
| | | 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 |
startPtr = Tcl_DuplicateObj(objv[i]);
} else {
startPtr = objv[i];
}
Tcl_IncrRefCount(startPtr);
break;
case LSEARCH_STRIDE: /* -stride */
if (i + 4 > (size_t)objc) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-stride\" option must be "
"followed by stride length", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
result = TCL_ERROR;
goto done;
}
|
| ︙ | ︙ | |||
3317 3318 3319 3320 3321 3322 3323 |
goto done;
}
groupSize = wide;
i++;
break;
case LSEARCH_INDEX: { /* -index */
Tcl_Obj **indices;
| | | | | 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 |
goto done;
}
groupSize = wide;
i++;
break;
case LSEARCH_INDEX: { /* -index */
Tcl_Obj **indices;
size_t j;
if (allocatedIndexVector) {
TclStackFree(interp, sortInfo.indexv);
allocatedIndexVector = 0;
}
if (i + 4 > (size_t)objc) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-index\" option must be followed by list index",
-1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
result = TCL_ERROR;
goto done;
}
/*
* Store the extracted indices for processing by sublist
* extraction. Note that we don't do this using objects because
* that has shimmering problems.
*/
i++;
if (TclListObjGetElementsM(interp, objv[i],
&sortInfo.indexc, &indices) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
switch (sortInfo.indexc) {
case 0:
sortInfo.indexv = NULL;
|
| ︙ | ︙ | |||
3380 3381 3382 3383 3384 3385 3386 |
TclGetString(indices[j])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
"OUTOFRANGE", NULL);
result = TCL_ERROR;
}
if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
| | | 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 |
TclGetString(indices[j])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
"OUTOFRANGE", NULL);
result = TCL_ERROR;
}
if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (-index option item number %" TCL_Z_MODIFIER "u)", j));
goto done;
}
sortInfo.indexv[j] = encoded;
}
break;
}
}
|
| ︙ | ︙ | |||
3445 3446 3447 3448 3449 3450 3451 |
}
/*
* Make sure the list argument is a list object and get its length and a
* pointer to its array of element pointers.
*/
| | | 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 |
}
/*
* Make sure the list argument is a list object and get its length and a
* pointer to its array of element pointers.
*/
result = TclListObjGetElementsM(interp, objv[objc - 2], &listc, &listv);
if (result != TCL_OK) {
goto done;
}
/*
* Check for sanity when grouping elements of the overall list together
* because of the -stride option. [TIP #351]
|
| ︙ | ︙ | |||
3550 3551 3552 3553 3554 3555 3556 | } /* * List representation might have been shimmered; restore it. [Bug * 1844789] */ | | | | 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 |
}
/*
* List representation might have been shimmered; restore it. [Bug
* 1844789]
*/
TclListObjGetElementsM(NULL, objv[objc - 2], &listc, &listv);
break;
case REAL:
result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble);
if (result != TCL_OK) {
goto done;
}
/*
* List representation might have been shimmered; restore it. [Bug
* 1844789]
*/
TclListObjGetElementsM(NULL, objv[objc - 2], &listc, &listv);
break;
}
} else {
patternBytes = Tcl_GetStringFromObj(patObj, &length);
}
/*
|
| ︙ | ︙ | |||
3803 3804 3805 3806 3807 3808 3809 |
Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0,
groupSize, &listv[i]);
} else {
itemPtr = listv[i];
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
}
} else if (returnSubindices) {
| | | 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 |
Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0,
groupSize, &listv[i]);
} else {
itemPtr = listv[i];
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
}
} else if (returnSubindices) {
size_t j;
TclNewIndexObj(itemPtr, i+groupOffset);
for (j=0 ; j<sortInfo.indexc ; j++) {
Tcl_Obj *elObj;
size_t elValue = TclIndexDecode(sortInfo.indexv[j], listc);
TclNewIndexObj(elObj, elValue);
Tcl_ListObjAppendElement(interp, itemPtr, elObj);
|
| ︙ | ︙ | |||
3827 3828 3829 3830 3831 3832 3833 |
* Return everything or a single value.
*/
if (allMatches) {
Tcl_SetObjResult(interp, listPtr);
} else if (!inlineReturn) {
if (returnSubindices) {
| | | 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 |
* Return everything or a single value.
*/
if (allMatches) {
Tcl_SetObjResult(interp, listPtr);
} else if (!inlineReturn) {
if (returnSubindices) {
size_t j;
TclNewIndexObj(itemPtr, index+groupOffset);
for (j=0 ; j<sortInfo.indexc ; j++) {
Tcl_Obj *elObj;
size_t elValue = TclIndexDecode(sortInfo.indexv[j], listc);
TclNewIndexObj(elObj, elValue);
Tcl_ListObjAppendElement(interp, itemPtr, elObj);
|
| ︙ | ︙ | |||
3894 3895 3896 3897 3898 3899 3900 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LsetObjCmd( | | | 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LsetObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
Tcl_Obj *listPtr; /* Pointer to the list being altered. */
Tcl_Obj *finalValuePtr; /* Value finally assigned to the variable. */
|
| ︙ | ︙ | |||
3979 3980 3981 3982 3983 3984 3985 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LsortObjCmd( | | | | | | 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LsortObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
int indices, nocase = 0, indexc;
int sortMode = SORTMODE_ASCII;
int group, allocatedIndexVector = 0;
size_t j, idx, groupSize, groupOffset, length;
Tcl_WideInt wide;
Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr;
size_t i, elmArrSize;
SortElement *elementArray = NULL, *elementPtr;
SortInfo sortInfo; /* Information about this sort that needs to
* be passed to the comparison function. */
# define MAXCALLOC 1024000
# define NUM_LISTS 30
SortElement *subList[NUM_LISTS+1];
/* This array holds pointers to temporary
|
| ︙ | ︙ | |||
4034 4035 4036 4037 4038 4039 4040 |
sortInfo.resultCode = TCL_OK;
cmdPtr = NULL;
indices = 0;
group = 0;
groupSize = 1;
groupOffset = 0;
indexPtr = NULL;
| | | | 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 |
sortInfo.resultCode = TCL_OK;
cmdPtr = NULL;
indices = 0;
group = 0;
groupSize = 1;
groupOffset = 0;
indexPtr = NULL;
for (i = 1; i < (size_t)objc-1; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0,
&index) != TCL_OK) {
sortInfo.resultCode = TCL_ERROR;
goto done;
}
switch (index) {
case LSORT_ASCII:
sortInfo.sortMode = SORTMODE_ASCII;
break;
case LSORT_COMMAND:
if (i + 2 == (size_t)objc) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-command\" option must be followed "
"by comparison command", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
|
| ︙ | ︙ | |||
4067 4068 4069 4070 4071 4072 4073 |
case LSORT_DICTIONARY:
sortInfo.sortMode = SORTMODE_DICTIONARY;
break;
case LSORT_INCREASING:
sortInfo.isIncreasing = 1;
break;
case LSORT_INDEX: {
| | | | | | | 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 |
case LSORT_DICTIONARY:
sortInfo.sortMode = SORTMODE_DICTIONARY;
break;
case LSORT_INCREASING:
sortInfo.isIncreasing = 1;
break;
case LSORT_INDEX: {
size_t sortindex;
Tcl_Obj **indexv;
if (i + 2 == (size_t)objc) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-index\" option must be followed by list index",
-1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
if (TclListObjGetElementsM(interp, objv[i+1], &sortindex,
&indexv) != TCL_OK) {
sortInfo.resultCode = TCL_ERROR;
goto done;
}
/*
* Check each of the indices for syntactic correctness. Note that
* we do not store the converted values here because we do not
* know if this is the only -index option yet and so we can't
* allocate any space; that happens after the scan through all the
* options is done.
*/
for (j=0 ; j<sortindex ; j++) {
int encoded = 0;
int result = TclIndexEncode(interp, indexv[j],
TCL_INDEX_NONE, TCL_INDEX_NONE, &encoded);
if ((result == TCL_OK) && (encoded == (int)TCL_INDEX_NONE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"index \"%s\" out of range",
TclGetString(indexv[j])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
"OUTOFRANGE", NULL);
result = TCL_ERROR;
}
if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (-index option item number %" TCL_Z_MODIFIER "u)", j));
sortInfo.resultCode = TCL_ERROR;
goto done;
}
}
indexPtr = objv[i+1];
i++;
break;
|
| ︙ | ︙ | |||
4132 4133 4134 4135 4136 4137 4138 | case LSORT_UNIQUE: sortInfo.unique = 1; break; case LSORT_INDICES: indices = 1; break; case LSORT_STRIDE: | | | 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 |
case LSORT_UNIQUE:
sortInfo.unique = 1;
break;
case LSORT_INDICES:
indices = 1;
break;
case LSORT_STRIDE:
if (i + 2 == (size_t)objc) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-stride\" option must be "
"followed by stride length", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
|
| ︙ | ︙ | |||
4171 4172 4173 4174 4175 4176 4177 |
* expected here; the values are all of the right type or convertible to
* it.
*/
if (indexPtr) {
Tcl_Obj **indexv;
| | | | 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 |
* expected here; the values are all of the right type or convertible to
* it.
*/
if (indexPtr) {
Tcl_Obj **indexv;
TclListObjGetElementsM(interp, indexPtr, &sortInfo.indexc, &indexv);
switch (sortInfo.indexc) {
case 0:
sortInfo.indexv = NULL;
break;
case 1:
sortInfo.indexv = &sortInfo.singleIndex;
break;
default:
sortInfo.indexv = (int *)
TclStackAlloc(interp, sizeof(int) * sortInfo.indexc);
allocatedIndexVector = 1; /* Cannot use indexc field, as it
* might be decreased by 1 later. */
}
for (j=0 ; j<sortInfo.indexc ; j++) {
/* Prescreened values, no errors or out of range possible */
TclIndexEncode(NULL, indexv[j], TCL_INDEX_NONE,
TCL_INDEX_NONE, &sortInfo.indexv[j]);
}
}
listObj = objv[objc-1];
|
| ︙ | ︙ | |||
4231 4232 4233 4234 4235 4236 4237 |
sortInfo.resultCode = TCL_ERROR;
goto done;
}
Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj());
sortInfo.compareCmdPtr = newCommandPtr;
}
| | | 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 |
sortInfo.resultCode = TCL_ERROR;
goto done;
}
Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj());
sortInfo.compareCmdPtr = newCommandPtr;
}
sortInfo.resultCode = TclListObjGetElementsM(interp, listObj,
&length, &listObjPtrs);
if (sortInfo.resultCode != TCL_OK || length <= 0) {
goto done;
}
/*
* Check for sanity when grouping elements of the overall list together
|
| ︙ | ︙ | |||
4326 4327 4328 4329 4330 4331 4332 |
if (elmArrSize <= MAXCALLOC) {
elementArray = (SortElement *)Tcl_Alloc(elmArrSize);
} else {
elementArray = (SortElement *)malloc(elmArrSize);
}
if (!elementArray) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 |
if (elmArrSize <= MAXCALLOC) {
elementArray = (SortElement *)Tcl_Alloc(elmArrSize);
} else {
elementArray = (SortElement *)malloc(elmArrSize);
}
if (!elementArray) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no enough memory to proccess sort of %" TCL_Z_MODIFIER "u items", length));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
for (i=0; i < length; i++) {
idx = groupSize * i + groupOffset;
|
| ︙ | ︙ | |||
4415 4416 4417 4418 4419 4420 4421 |
}
/*
* Now store the sorted elements in the result list.
*/
if (sortInfo.resultCode == TCL_OK) {
| | | | | 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 |
}
/*
* Now store the sorted elements in the result list.
*/
if (sortInfo.resultCode == TCL_OK) {
ListRep listRep;
Tcl_Obj **newArray, *objPtr;
resultPtr = Tcl_NewListObj(sortInfo.numElements * groupSize, NULL);
ListObjGetRep(resultPtr, &listRep);
newArray = ListRepElementsBase(&listRep);
if (group) {
for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) {
idx = elementPtr->payload.index;
for (j = 0; j < groupSize; j++) {
if (indices) {
TclNewIndexObj(objPtr, idx + j - groupOffset);
newArray[i++] = objPtr;
|
| ︙ | ︙ | |||
4449 4450 4451 4452 4453 4454 4455 |
} else {
for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) {
objPtr = elementPtr->payload.objPtr;
newArray[i++] = objPtr;
Tcl_IncrRefCount(objPtr);
}
}
| > | > > > | 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 |
} else {
for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) {
objPtr = elementPtr->payload.objPtr;
newArray[i++] = objPtr;
Tcl_IncrRefCount(objPtr);
}
}
listRep.storePtr->numUsed = i;
if (listRep.spanPtr) {
listRep.spanPtr->spanStart = listRep.storePtr->firstUsed;
listRep.spanPtr->spanLength = listRep.storePtr->numUsed;
}
Tcl_SetObjResult(interp, resultPtr);
}
done:
if (sortMode == SORTMODE_COMMAND) {
TclDecrRefCount(sortInfo.compareCmdPtr);
TclDecrRefCount(listObj);
|
| ︙ | ︙ | |||
4624 4625 4626 4627 4628 4629 4630 |
double a, b;
a = elemPtr1->collationKey.doubleValue;
b = elemPtr2->collationKey.doubleValue;
order = ((a >= b) - (a <= b));
} else {
Tcl_Obj **objv, *paramObjv[2];
| | | 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 |
double a, b;
a = elemPtr1->collationKey.doubleValue;
b = elemPtr2->collationKey.doubleValue;
order = ((a >= b) - (a <= b));
} else {
Tcl_Obj **objv, *paramObjv[2];
size_t objc;
Tcl_Obj *objPtr1, *objPtr2;
if (infoPtr->resultCode != TCL_OK) {
/*
* Once an error has occurred, skip any future comparisons so as
* to preserve the error message in sortInterp->result.
*/
|
| ︙ | ︙ | |||
4648 4649 4650 4651 4652 4653 4654 | paramObjv[1] = objPtr2; /* * We made space in the command list for the two things to compare. * Replace them and evaluate the result. */ | | | | 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 |
paramObjv[1] = objPtr2;
/*
* We made space in the command list for the two things to compare.
* Replace them and evaluate the result.
*/
TclListObjLengthM(infoPtr->interp, infoPtr->compareCmdPtr, &objc);
Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2,
2, 2, paramObjv);
TclListObjGetElementsM(infoPtr->interp, infoPtr->compareCmdPtr,
&objc, &objv);
infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0);
if (infoPtr->resultCode != TCL_OK) {
Tcl_AddErrorInfo(infoPtr->interp, "\n (-compare command)");
return 0;
|
| ︙ | ︙ | |||
4842 4843 4844 4845 4846 4847 4848 |
static Tcl_Obj *
SelectObjFromSublist(
Tcl_Obj *objPtr, /* Obj to select sublist from. */
SortInfo *infoPtr) /* Information passed from the top-level
* "lsearch" or "lsort" command. */
{
| | | > | | 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 |
static Tcl_Obj *
SelectObjFromSublist(
Tcl_Obj *objPtr, /* Obj to select sublist from. */
SortInfo *infoPtr) /* Information passed from the top-level
* "lsearch" or "lsort" command. */
{
size_t i;
/*
* Quick check for case when no "-index" option is there.
*/
if (infoPtr->indexc == 0) {
return objPtr;
}
/*
* Iterate over the indices, traversing through the nested sublists as we
* go.
*/
for (i=0 ; i<infoPtr->indexc ; i++) {
size_t listLen;
int index;
Tcl_Obj *currentObj;
if (TclListObjLengthM(infoPtr->interp, objPtr, &listLen) != TCL_OK) {
infoPtr->resultCode = TCL_ERROR;
return NULL;
}
index = TclIndexDecode(infoPtr->indexv[i], listLen - 1);
if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index,
|
| ︙ | ︙ |
Changes to generic/tclCmdMZ.c.
| ︙ | ︙ | |||
78 79 80 81 82 83 84 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_PwdObjCmd( | | | 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_PwdObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *retVal;
if (objc != 1) {
|
| ︙ | ︙ | |||
118 119 120 121 122 123 124 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_RegexpObjCmd( | | | 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_RegexpObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
size_t matchLength, cflags, eflags;
ssize_t stringLength, offset;
int i, indices, match, about, all, doinline, numMatchesSaved;
|
| ︙ | ︙ | |||
478 479 480 481 482 483 484 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_RegsubObjCmd( | | | | | 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_RegsubObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int result, cflags, all, match, command;
size_t idx, wsublen = 0, numMatches;
ssize_t offset, wlen, numParts;
size_t start, end;
ssize_t subStart, subEnd;
Tcl_RegExp regExpr;
Tcl_RegExpInfo info;
Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL;
Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec = 0, *wend;
|
| ︙ | ︙ | |||
672 673 674 675 676 677 678 | /* * In command-prefix mode, we require that the third non-option * argument be a list, so we enforce that here. Afterwards, we fetch * the RE compilation again in case objv[0] and objv[2] are the same * object. (If they aren't, that's cheap to do.) */ | | | 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 |
/*
* In command-prefix mode, we require that the third non-option
* argument be a list, so we enforce that here. Afterwards, we fetch
* the RE compilation again in case objv[0] and objv[2] are the same
* object. (If they aren't, that's cheap to do.)
*/
if (TclListObjLengthM(interp, objv[2], &numParts) != TCL_OK) {
return TCL_ERROR;
}
if (numParts < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command prefix must be a list of at least one element",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGSUB",
|
| ︙ | ︙ | |||
772 773 774 775 776 777 778 |
* arguments to the subSpec to form a command, that is then executed
* and the result used as the string to substitute in. Actually,
* everything is passed through Tcl_EvalObjv, as that's much faster.
*/
if (command) {
Tcl_Obj **args = NULL, **parts;
| | | | 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 |
* arguments to the subSpec to form a command, that is then executed
* and the result used as the string to substitute in. Actually,
* everything is passed through Tcl_EvalObjv, as that's much faster.
*/
if (command) {
Tcl_Obj **args = NULL, **parts;
size_t numArgs;
TclListObjGetElementsM(interp, subPtr, &numParts, &parts);
numArgs = numParts + info.nsubs + 1;
args = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj*) * numArgs);
memcpy(args, parts, sizeof(Tcl_Obj*) * numParts);
for (idx = 0 ; idx <= info.nsubs ; idx++) {
subStart = info.matches[idx].start;
subEnd = info.matches[idx].end;
|
| ︙ | ︙ | |||
1000 1001 1002 1003 1004 1005 1006 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_RenameObjCmd( | | | 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_RenameObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *oldName, *newName;
if (objc != 3) {
|
| ︙ | ︙ | |||
1036 1037 1038 1039 1040 1041 1042 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_ReturnObjCmd( | | | 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ReturnObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int code, level;
Tcl_Obj *returnOpts;
|
| ︙ | ︙ | |||
1083 1084 1085 1086 1087 1088 1089 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_SourceObjCmd( | | | | 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_SourceObjCmd(
void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRSourceObjCmd, clientData, objc, objv);
}
int
TclNRSourceObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *encodingName = NULL;
Tcl_Obj *fileName;
int result;
|
| ︙ | ︙ | |||
1167 1168 1169 1170 1171 1172 1173 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_SplitObjCmd( | | | 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_SplitObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int ch = 0;
int len;
const char *splitChars;
|
| ︙ | ︙ | |||
1300 1301 1302 1303 1304 1305 1306 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringFirstCmd( | | | 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringFirstCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
size_t start = TCL_INDEX_START;
if (objc < 3 || objc > 4) {
|
| ︙ | ︙ | |||
1344 1345 1346 1347 1348 1349 1350 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringLastCmd( | | | 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringLastCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
size_t last = TCL_INDEX_END;
if (objc < 3 || objc > 4) {
|
| ︙ | ︙ | |||
1388 1389 1390 1391 1392 1393 1394 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringIndexCmd( | | | 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringIndexCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
ssize_t index, end;
if (objc != 3) {
|
| ︙ | ︙ | |||
1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 |
unsigned char uch = UCHAR(ch);
Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(&uch, 1));
} else {
char buf[4] = "";
end = Tcl_UniCharToUtf(ch, buf);
if ((ch >= 0xD800) && (end < 3)) {
end += Tcl_UniCharToUtf(-1, buf + end);
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, end));
}
}
return TCL_OK;
}
/*
| > > | 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 |
unsigned char uch = UCHAR(ch);
Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(&uch, 1));
} else {
char buf[4] = "";
end = Tcl_UniCharToUtf(ch, buf);
#if TCL_UTF_MAX < 4
if ((ch >= 0xD800) && (end < 3)) {
end += Tcl_UniCharToUtf(-1, buf + end);
}
#endif
Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, end));
}
}
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
1458 1459 1460 1461 1462 1463 1464 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringInsertCmd( | | | 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringInsertCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument objects */
{
size_t length; /* String length */
ssize_t index; /* Insert index */
Tcl_Obj *outObj; /* Output object */
|
| ︙ | ︙ | |||
1519 1520 1521 1522 1523 1524 1525 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringIsCmd( | | | | < | 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringIsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *end, *stop;
int (*chcomp)(int) = NULL; /* The UniChar comparison function. */
int i, result = 1, strict = 0;
size_t failat = 0, length1, length2, length3;
Tcl_Obj *objPtr, *failVarObj = NULL;
Tcl_WideInt w;
static const char *const isClasses[] = {
"alnum", "alpha", "ascii", "control",
"boolean", "dict", "digit", "double",
"entier", "false", "graph", "integer",
|
| ︙ | ︙ | |||
1630 1631 1632 1633 1634 1635 1636 |
result = 0;
}
break;
case STR_IS_CONTROL:
chcomp = Tcl_UniCharIsControl;
break;
case STR_IS_DICT: {
| | > | 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 |
result = 0;
}
break;
case STR_IS_CONTROL:
chcomp = Tcl_UniCharIsControl;
break;
case STR_IS_DICT: {
int dresult;
size_t dsize;
dresult = Tcl_DictObjSize(interp, objPtr, &dsize);
Tcl_ResetResult(interp);
result = (dresult == TCL_OK) ? 1 : 0;
if (dresult != TCL_OK && failVarObj != NULL) {
/*
* Need to figure out where the list parsing failed, which is
|
| ︙ | ︙ | |||
1812 1813 1814 1815 1816 1817 1818 |
break;
case STR_IS_LIST:
/*
* We ignore the strictness here, since empty strings are always
* well-formed lists.
*/
| | | 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 |
break;
case STR_IS_LIST:
/*
* We ignore the strictness here, since empty strings are always
* well-formed lists.
*/
if (TCL_OK == TclListObjLengthM(NULL, objPtr, &length3)) {
break;
}
if (failVarObj != NULL) {
/*
* Need to figure out where the list parsing failed, which is
* fairly expensive. This is adapted from the core of
|
| ︙ | ︙ | |||
1955 1956 1957 1958 1959 1960 1961 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringMapCmd( | | | 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringMapCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
size_t length1, length2, mapElemc, index;
int nocase = 0, mapWithDict = 0, copySource = 0;
Tcl_Obj **mapElemv, *sourceObj, *resultPtr;
|
| ︙ | ︙ | |||
1993 1994 1995 1996 1997 1998 1999 |
/*
* This test is tricky, but has to be that way or you get other strange
* inconsistencies (see test string-10.20.1 for illustration why!)
*/
if (!TclHasStringRep(objv[objc-2])
&& TclHasInternalRep(objv[objc-2], &tclDictType)) {
| > | | 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 |
/*
* This test is tricky, but has to be that way or you get other strange
* inconsistencies (see test string-10.20.1 for illustration why!)
*/
if (!TclHasStringRep(objv[objc-2])
&& TclHasInternalRep(objv[objc-2], &tclDictType)) {
size_t i;
int done;
Tcl_DictSearch search;
/*
* We know the type exactly, so all dict operations will succeed for
* sure. This shortens this code quite a bit.
*/
|
| ︙ | ︙ | |||
2027 2028 2029 2030 2031 2032 2033 |
Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0,
mapElemv+1, &done);
for (index=2 ; index<mapElemc ; index+=2) {
Tcl_DictObjNext(&search, mapElemv+index, mapElemv+index+1, &done);
}
Tcl_DictObjDone(&search);
} else {
| | | | 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 |
Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0,
mapElemv+1, &done);
for (index=2 ; index<mapElemc ; index+=2) {
Tcl_DictObjNext(&search, mapElemv+index, mapElemv+index+1, &done);
}
Tcl_DictObjDone(&search);
} else {
size_t i;
if (TclListObjGetElementsM(interp, objv[objc-2], &i,
&mapElemv) != TCL_OK) {
return TCL_ERROR;
}
mapElemc = i;
if (mapElemc == 0) {
/*
* empty charMap, just return whatever string was given.
|
| ︙ | ︙ | |||
2230 2231 2232 2233 2234 2235 2236 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringMatchCmd( | | | 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringMatchCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int nocase = 0;
if (objc < 3 || objc > 4) {
|
| ︙ | ︙ | |||
2282 2283 2284 2285 2286 2287 2288 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringRangeCmd( | | | 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringRangeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
size_t first, end;
ssize_t last;
|
| ︙ | ︙ | |||
2333 2334 2335 2336 2337 2338 2339 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringReptCmd( | | | 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringReptCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int count;
Tcl_Obj *resultPtr;
|
| ︙ | ︙ | |||
2389 2390 2391 2392 2393 2394 2395 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringRplcCmd( | | | 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringRplcCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
ssize_t first, last, end;
if (objc < 4 || objc > 5) {
|
| ︙ | ︙ | |||
2463 2464 2465 2466 2467 2468 2469 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringRevCmd( | | | 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringRevCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "string");
return TCL_ERROR;
|
| ︙ | ︙ | |||
2496 2497 2498 2499 2500 2501 2502 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringStartCmd( | | | 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringStartCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int ch;
const Tcl_UniChar *p, *string;
ssize_t index, length;
|
| ︙ | ︙ | |||
2567 2568 2569 2570 2571 2572 2573 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringEndCmd( | | | 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringEndCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int ch;
const Tcl_UniChar *p, *end, *string;
ssize_t cur, length;
|
| ︙ | ︙ | |||
2630 2631 2632 2633 2634 2635 2636 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringEqualCmd( | | | 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringEqualCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
/*
* Remember to keep code here in some sync with the byte-compiled versions
* in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as
|
| ︙ | ︙ | |||
2706 2707 2708 2709 2710 2711 2712 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringCmpCmd( | | | 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringCmpCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
/*
* Remember to keep code here in some sync with the byte-compiled versions
* in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as
|
| ︙ | ︙ | |||
2795 2796 2797 2798 2799 2800 2801 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringCatCmd( | | | 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringCatCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *objResultPtr;
if (objc < 2) {
|
| ︙ | ︙ | |||
2840 2841 2842 2843 2844 2845 2846 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringLenCmd( | | | 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringLenCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "string");
return TCL_ERROR;
|
| ︙ | ︙ | |||
2874 2875 2876 2877 2878 2879 2880 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringLowerCmd( | | | 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringLowerCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
ssize_t length1, length2;
const char *string1;
char *string2;
|
| ︙ | ︙ | |||
2959 2960 2961 2962 2963 2964 2965 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringUpperCmd( | | | 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringUpperCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
ssize_t length1, length2;
const char *string1;
char *string2;
|
| ︙ | ︙ | |||
3044 3045 3046 3047 3048 3049 3050 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringTitleCmd( | | | 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringTitleCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
ssize_t length1, length2;
const char *string1;
char *string2;
|
| ︙ | ︙ | |||
3129 3130 3131 3132 3133 3134 3135 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringTrimCmd( | | | 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringTrimCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
size_t triml, trimr, length1, length2;
|
| ︙ | ︙ | |||
3176 3177 3178 3179 3180 3181 3182 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringTrimLCmd( | | | 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringTrimLCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
int trim;
size_t length1, length2;
|
| ︙ | ︙ | |||
3223 3224 3225 3226 3227 3228 3229 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringTrimRCmd( | | | 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringTrimRCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
int trim;
size_t length1, length2;
|
| ︙ | ︙ | |||
3327 3328 3329 3330 3331 3332 3333 |
*
*----------------------------------------------------------------------
*/
int
TclSubstOptions(
Tcl_Interp *interp,
| | > | 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 |
*
*----------------------------------------------------------------------
*/
int
TclSubstOptions(
Tcl_Interp *interp,
size_t numOpts1,
Tcl_Obj *const opts[],
int *flagPtr)
{
static const char *const substOptions[] = {
"-nobackslashes", "-nocommands", "-novariables", NULL
};
enum {
SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS
};
int i, flags = TCL_SUBST_ALL;
int numOpts = numOpts1;
for (i = 0; i < numOpts; i++) {
int optionIndex;
if (Tcl_GetIndexFromObj(interp, opts[i], substOptions, "option", 0,
&optionIndex) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
3366 3367 3368 3369 3370 3371 3372 |
}
*flagPtr = flags;
return TCL_OK;
}
int
Tcl_SubstObjCmd(
| | | | 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 |
}
*flagPtr = flags;
return TCL_OK;
}
int
Tcl_SubstObjCmd(
void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRSubstObjCmd, clientData, objc, objv);
}
int
TclNRSubstObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int flags;
if (objc < 2) {
|
| ︙ | ︙ | |||
3414 3415 3416 3417 3418 3419 3420 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_SwitchObjCmd( | | | | 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_SwitchObjCmd(
void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRSwitchObjCmd, clientData, objc, objv);
}
int
TclNRSwitchObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, mode, foundmode, splitObjs, numMatchesSaved;
int noCase;
size_t patternLength, j;
|
| ︙ | ︙ | |||
3578 3579 3580 3581 3582 3583 3584 3585 3586 |
* the same data for the list word itself. The cmdFramePtr line
* information is manipulated directly.
*/
splitObjs = 0;
if (objc == 1) {
Tcl_Obj **listv;
blist = objv[0];
| > | | > | 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 |
* the same data for the list word itself. The cmdFramePtr line
* information is manipulated directly.
*/
splitObjs = 0;
if (objc == 1) {
Tcl_Obj **listv;
size_t listc;
blist = objv[0];
if (TclListObjGetElementsM(interp, objv[0], &listc, &listv) != TCL_OK) {
return TCL_ERROR;
}
/*
* Ensure that the list is non-empty.
*/
if (listc < 1 || listc > INT_MAX) {
Tcl_WrongNumArgs(interp, 1, savedObjv,
"?-option ...? string {?pattern body ...? ?default body?}");
return TCL_ERROR;
}
objc = listc;
objv = listv;
splitObjs = 1;
}
/*
* Complain if there is an odd number of words in the list of patterns and
* bodies.
|
| ︙ | ︙ | |||
3879 3880 3881 3882 3883 3884 3885 |
}
/*
* TIP #280: Make invoking context available to switch branch.
*/
Tcl_NRAddCallback(interp, SwitchPostProc, INT2PTR(splitObjs), ctxPtr,
| | | | 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 |
}
/*
* TIP #280: Make invoking context available to switch branch.
*/
Tcl_NRAddCallback(interp, SwitchPostProc, INT2PTR(splitObjs), ctxPtr,
INT2PTR(pc), (void *)pattern);
return TclNREvalObjEx(interp, objv[j], 0, ctxPtr, splitObjs ? j : bidx+j);
}
static int
SwitchPostProc(
void *data[], /* Data passed from Tcl_NRAddCallback above */
Tcl_Interp *interp, /* Tcl interpreter */
int result) /* Result to return*/
{
/* Unpack the preserved data */
int splitObjs = PTR2INT(data[0]);
CmdFrame *ctxPtr = (CmdFrame *)data[1];
|
| ︙ | ︙ | |||
3948 3949 3950 3951 3952 3953 3954 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_ThrowObjCmd( | | | | | 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ThrowObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *options;
size_t len;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "type message");
return TCL_ERROR;
}
/*
* The type must be a list of at least length 1.
*/
if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) {
return TCL_ERROR;
} else if (len < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"type must be non-empty list", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "THROW", "BADEXCEPTION",
NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
4010 4011 4012 4013 4014 4015 4016 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_TimeObjCmd( | | | 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_TimeObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *objPtr;
Tcl_Obj *objs[4];
int i, result;
|
| ︙ | ︙ | |||
4108 4109 4110 4111 4112 4113 4114 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_TimeRateObjCmd( | | | 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_TimeRateObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static double measureOverhead = 0;
/* global measure-overhead */
double overhead = -1; /* given measure-overhead */
|
| ︙ | ︙ | |||
4654 4655 4656 4657 4658 4659 4660 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_TryObjCmd( | | | | > | 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_TryObjCmd(
void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRTryObjCmd, clientData, objc, objv);
}
int
TclNRTryObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *bodyObj, *handlersObj, *finallyObj = NULL;
int i, bodyShared, haveHandlers, code;
size_t dummy;
static const char *const handlerNames[] = {
"finally", "on", "trap", NULL
};
enum Handlers {
TryFinally, TryOn, TryTrap
};
|
| ︙ | ︙ | |||
4753 4754 4755 4756 4757 4758 4759 | -1)); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", "ARGUMENT", NULL); return TCL_ERROR; } code = 1; | | | | 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 |
-1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP",
"ARGUMENT", NULL);
return TCL_ERROR;
}
code = 1;
if (TclListObjLengthM(NULL, objv[i+1], &dummy) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad prefix '%s': must be a list",
TclGetString(objv[i+1])));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP",
"EXNFORMAT", NULL);
return TCL_ERROR;
}
info[2] = objv[i+1];
commonHandler:
if (TclListObjLengthM(interp, objv[i+2], &dummy) != TCL_OK) {
Tcl_DecrRefCount(handlersObj);
return TCL_ERROR;
}
info[0] = objv[i]; /* type */
TclNewIntObj(info[1], code); /* returnCode */
if (info[2] == NULL) { /* errorCodePrefix */
|
| ︙ | ︙ | |||
4804 4805 4806 4807 4808 4809 4810 |
}
/*
* Execute the body.
*/
Tcl_NRAddCallback(interp, TryPostBody, handlersObj, finallyObj,
| | | 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 |
}
/*
* Execute the body.
*/
Tcl_NRAddCallback(interp, TryPostBody, handlersObj, finallyObj,
(void *)objv, INT2PTR(objc));
return TclNREvalObjEx(interp, bodyObj, 0,
((Interp *) interp)->cmdFramePtr, 1);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4862 4863 4864 4865 4866 4867 4868 | * command. * *---------------------------------------------------------------------- */ static int TryPostBody( | | | | | 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 |
* command.
*
*----------------------------------------------------------------------
*/
static int
TryPostBody(
void *data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj *resultObj, *options, *handlersObj, *finallyObj, *cmdObj, **objv;
int code, objc;
size_t i, numHandlers = 0;
handlersObj = (Tcl_Obj *)data[0];
finallyObj = (Tcl_Obj *)data[1];
objv = (Tcl_Obj **)data[2];
objc = PTR2INT(data[3]);
cmdObj = objv[0];
|
| ︙ | ︙ | |||
4915 4916 4917 4918 4919 4920 4921 |
* Handle the results.
*/
if (handlersObj != NULL) {
int found = 0;
Tcl_Obj **handlers, **info;
| | | | | | | | 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 |
* Handle the results.
*/
if (handlersObj != NULL) {
int found = 0;
Tcl_Obj **handlers, **info;
TclListObjGetElementsM(NULL, handlersObj, &numHandlers, &handlers);
for (i=0 ; i<numHandlers ; i++) {
Tcl_Obj *handlerBodyObj;
size_t numElems = 0;
TclListObjGetElementsM(NULL, handlers[i], &numElems, &info);
if (!found) {
Tcl_GetIntFromObj(NULL, info[1], &code);
if (code != result) {
continue;
}
/*
* When processing an error, we must also perform list-prefix
* matching of the errorcode list. However, if this was an
* 'on' handler, the list that we are matching against will be
* empty.
*/
if (code == TCL_ERROR) {
Tcl_Obj *errorCodeName, *errcode, **bits1, **bits2;
size_t len1, len2, j;
TclNewLiteralStringObj(errorCodeName, "-errorcode");
Tcl_DictObjGet(NULL, options, errorCodeName, &errcode);
Tcl_DecrRefCount(errorCodeName);
TclListObjGetElementsM(NULL, info[2], &len1, &bits1);
if (TclListObjGetElementsM(NULL, errcode, &len2,
&bits2) != TCL_OK) {
continue;
}
if (len2 < len1) {
continue;
}
for (j=0 ; j<len1 ; j++) {
|
| ︙ | ︙ | |||
4982 4983 4984 4985 4986 4987 4988 | /* * Bind the variables. We already know this is a list of variable * names, but it might be empty. */ Tcl_ResetResult(interp); result = TCL_ERROR; | | | 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 |
/*
* Bind the variables. We already know this is a list of variable
* names, but it might be empty.
*/
Tcl_ResetResult(interp);
result = TCL_ERROR;
TclListObjLengthM(NULL, info[3], &numElems);
if (numElems> 0) {
Tcl_Obj *varName;
Tcl_ListObjIndex(NULL, info[3], 0, &varName);
if (Tcl_ObjSetVar2(interp, varName, NULL, resultObj,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_DecrRefCount(resultObj);
|
| ︙ | ︙ | |||
5078 5079 5080 5081 5082 5083 5084 | * 'try' command. * *---------------------------------------------------------------------- */ static int TryPostHandler( | | | 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 |
* 'try' command.
*
*----------------------------------------------------------------------
*/
static int
TryPostHandler(
void *data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj *resultObj, *cmdObj, *options, *handlerKindObj, **objv;
Tcl_Obj *finallyObj;
int finallyIndex;
|
| ︙ | ︙ | |||
5164 5165 5166 5167 5168 5169 5170 | * of a 'try' command. * *---------------------------------------------------------------------- */ static int TryPostFinal( | | | 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 |
* of a 'try' command.
*
*----------------------------------------------------------------------
*/
static int
TryPostFinal(
void *data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj *resultObj, *options, *cmdObj;
resultObj = (Tcl_Obj *)data[0];
options = (Tcl_Obj *)data[1];
|
| ︙ | ︙ | |||
5231 5232 5233 5234 5235 5236 5237 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_WhileObjCmd( | | | | 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_WhileObjCmd(
void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRWhileObjCmd, clientData, objc, objv);
}
int
TclNRWhileObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
ForIterData *iterPtr;
if (objc != 3) {
|
| ︙ | ︙ | |||
5290 5291 5292 5293 5294 5295 5296 |
*/
void
TclListLines(
Tcl_Obj *listObj, /* Pointer to obj holding a string with list
* structure. Assumed to be valid. Assumed to
* contain n elements. */
| | | 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 |
*/
void
TclListLines(
Tcl_Obj *listObj, /* Pointer to obj holding a string with list
* structure. Assumed to be valid. Assumed to
* contain n elements. */
size_t line, /* Line the list as a whole starts on. */
int n, /* #elements in lines */
int *lines, /* Array of line numbers, to fill. */
Tcl_Obj *const *elems) /* The list elems as Tcl_Obj*, in need of
* derived continuation data */
{
const char *listStr = TclGetString(listObj);
const char *listHead = listStr;
|
| ︙ | ︙ |
Changes to generic/tclCompCmds.c.
| ︙ | ︙ | |||
282 283 284 285 286 287 288 |
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *dataTokenPtr;
int isScalar, localIndex, code = TCL_OK;
| | > | | 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 |
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *dataTokenPtr;
int isScalar, localIndex, code = TCL_OK;
int isDataLiteral, isDataValid, isDataEven;
size_t len;
int keyVar, valVar, infoIndex;
int fwd, offsetBack, offsetFwd;
Tcl_Obj *literalObj;
ForeachInfo *infoPtr;
if (parsePtr->numWords != 3) {
return TCL_ERROR;
}
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
dataTokenPtr = TokenAfter(varTokenPtr);
TclNewObj(literalObj);
isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj);
isDataValid = (isDataLiteral
&& TclListObjLengthM(NULL, literalObj, &len) == TCL_OK);
isDataEven = (isDataValid && (len & 1) == 0);
/*
* Special case: literal odd-length argument is always an error.
*/
if (isDataValid && !isDataEven) {
|
| ︙ | ︙ | |||
388 389 390 391 392 393 394 |
*/
keyVar = AnonymousLocal(envPtr);
valVar = AnonymousLocal(envPtr);
infoPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists) + sizeof(ForeachVarList *));
infoPtr->numLists = 1;
| | | 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 |
*/
keyVar = AnonymousLocal(envPtr);
valVar = AnonymousLocal(envPtr);
infoPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists) + sizeof(ForeachVarList *));
infoPtr->numLists = 1;
infoPtr->varLists[0] = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes) + 2 * sizeof(size_t));
infoPtr->varLists[0]->numVars = 2;
infoPtr->varLists[0]->varIndexes[0] = keyVar;
infoPtr->varLists[0]->varIndexes[1] = valVar;
infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr);
/*
* Start issuing instructions to write to the array.
|
| ︙ | ︙ | |||
579 580 581 582 583 584 585 |
int depth = TclGetStackDepth(envPtr);
/*
* If syntax does not match what we expect for [catch], do not compile.
* Let runtime checks determine if syntax has changed.
*/
| | | | | 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 611 612 613 614 |
int depth = TclGetStackDepth(envPtr);
/*
* If syntax does not match what we expect for [catch], do not compile.
* Let runtime checks determine if syntax has changed.
*/
if (((int)parsePtr->numWords < 2) || ((int)parsePtr->numWords > 4)) {
return TCL_ERROR;
}
/*
* If variables were specified and the catch command is at global level
* (not in a procedure), don't compile it inline: the payoff is too small.
*/
if (((int)parsePtr->numWords >= 3) && !EnvHasLVT(envPtr)) {
return TCL_ERROR;
}
/*
* Make sure the variable names, if any, have no substitutions and just
* refer to local scalars.
*/
resultIndex = optsIndex = -1;
cmdTokenPtr = TokenAfter(parsePtr->tokenPtr);
if ((int)parsePtr->numWords >= 3) {
resultNameTokenPtr = TokenAfter(cmdTokenPtr);
/* DGP */
resultIndex = LocalScalarFromToken(resultNameTokenPtr, envPtr);
if (resultIndex < 0) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
872 873 874 875 876 877 878 |
/*
* Test if all arguments are compile-time known. If they are, we can
* implement with a simple push.
*/
TclNewObj(listObj);
| | < | | | | 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 909 910 911 912 913 914 915 916 |
/*
* Test if all arguments are compile-time known. If they are, we can
* implement with a simple push.
*/
TclNewObj(listObj);
for (i = 1, tokenPtr = parsePtr->tokenPtr; i < (int)parsePtr->numWords; i++) {
tokenPtr = TokenAfter(tokenPtr);
TclNewObj(objPtr);
if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(listObj);
listObj = NULL;
break;
}
(void) Tcl_ListObjAppendElement(NULL, listObj, objPtr);
}
if (listObj != NULL) {
Tcl_Obj **objs;
const char *bytes;
size_t len, slen;
TclListObjGetElementsM(NULL, listObj, &len, &objs);
objPtr = Tcl_ConcatObj(len, objs);
Tcl_DecrRefCount(listObj);
bytes = Tcl_GetStringFromObj(objPtr, &slen);
PushLiteral(envPtr, bytes, slen);
Tcl_DecrRefCount(objPtr);
return TCL_OK;
}
/*
* General case: runtime concat.
*/
for (i = 1, tokenPtr = parsePtr->tokenPtr; i < (int)parsePtr->numWords; i++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, i);
}
TclEmitInstInt4( INST_CONCAT_STK, i-1, envPtr);
return TCL_OK;
|
| ︙ | ︙ | |||
1009 1010 1011 1012 1013 1014 1015 |
int i, dictVarIndex;
Tcl_Token *varTokenPtr;
/*
* There must be at least one argument after the command.
*/
| | | | | 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 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 |
int i, dictVarIndex;
Tcl_Token *varTokenPtr;
/*
* There must be at least one argument after the command.
*/
if ((int)parsePtr->numWords < 4) {
return TCL_ERROR;
}
/*
* The dictionary variable must be a local scalar that is knowable at
* compile time; anything else exceeds the complexity of the opcode. So
* discover what the index is.
*/
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr);
if (dictVarIndex < 0) {
return TCL_ERROR;
}
/*
* Remaining words (key path and value to set) can be handled normally.
*/
tokenPtr = TokenAfter(varTokenPtr);
for (i=2 ; i< (int)parsePtr->numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
/*
* Now emit the instruction to do the dict manipulation.
*/
TclEmitInstInt4( INST_DICT_SET, (int)parsePtr->numWords-3, envPtr);
TclEmitInt4( dictVarIndex, envPtr);
TclAdjustStackDepth(-1, envPtr);
return TCL_OK;
}
int
TclCompileDictIncrCmd(
|
| ︙ | ︙ | |||
1062 1063 1064 1065 1066 1067 1068 |
Tcl_Token *varTokenPtr, *keyTokenPtr;
int dictVarIndex, incrAmount;
/*
* There must be at least two arguments after the command.
*/
| | | 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 |
Tcl_Token *varTokenPtr, *keyTokenPtr;
int dictVarIndex, incrAmount;
/*
* There must be at least two arguments after the command.
*/
if ((int)parsePtr->numWords < 3 || (int)parsePtr->numWords > 4) {
return TCL_ERROR;
}
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
keyTokenPtr = TokenAfter(varTokenPtr);
/*
* Parse the increment amount, if present.
|
| ︙ | ︙ | |||
1136 1137 1138 1139 1140 1141 1142 |
/*
* 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. */
| | | | | 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 |
/*
* 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 ((int)parsePtr->numWords < 3) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
/*
* Only compile this because we need INST_DICT_GET anyway.
*/
for (i=1 ; i<(int)parsePtr->numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4(INST_DICT_GET, (int)parsePtr->numWords-2, envPtr);
TclAdjustStackDepth(-1, envPtr);
return TCL_OK;
}
int
TclCompileDictGetWithDefaultCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
|
| ︙ | ︙ | |||
1171 1172 1173 1174 1175 1176 1177 |
int i;
/*
* There must be at least three arguments after the command.
*/
/* TODO: Consider support for compiling expanded args. */
| | | | | 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 |
int i;
/*
* There must be at least three arguments after the command.
*/
/* TODO: Consider support for compiling expanded args. */
if ((int)parsePtr->numWords < 4) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
for (i=1 ; i<(int)parsePtr->numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4(INST_DICT_GET_DEF, (int)parsePtr->numWords-3, envPtr);
TclAdjustStackDepth(-2, envPtr);
return TCL_OK;
}
int
TclCompileDictExistsCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
|
| ︙ | ︙ | |||
1203 1204 1205 1206 1207 1208 1209 |
/*
* 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. */
| | | | | 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 |
/*
* 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 ((int)parsePtr->numWords < 3) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
/*
* Now we do the code generation.
*/
for (i=1 ; i<(int)parsePtr->numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4(INST_DICT_EXISTS, (int)parsePtr->numWords-2, envPtr);
TclAdjustStackDepth(-1, envPtr);
return TCL_OK;
}
int
TclCompileDictUnsetCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
|
| ︙ | ︙ | |||
1240 1241 1242 1243 1244 1245 1246 |
/*
* There must be at least one argument after the variable name for us to
* compile to bytecode.
*/
/* TODO: Consider support for compiling expanded args. */
| | | | | 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 |
/*
* There must be at least one argument after the variable name for us to
* compile to bytecode.
*/
/* TODO: Consider support for compiling expanded args. */
if ((int)parsePtr->numWords < 3) {
return TCL_ERROR;
}
/*
* The dictionary variable must be a local scalar that is knowable at
* compile time; anything else exceeds the complexity of the opcode. So
* discover what the index is.
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr);
if (dictVarIndex < 0) {
return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
* Remaining words (the key path) can be handled normally.
*/
for (i=2 ; i<(int)parsePtr->numWords ; i++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, i);
}
/*
* Now emit the instruction to do the dict manipulation.
*/
TclEmitInstInt4( INST_DICT_UNSET, (int)parsePtr->numWords-2, envPtr);
TclEmitInt4( dictVarIndex, envPtr);
return TCL_OK;
}
int
TclCompileDictCreateCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
|
| ︙ | ︙ | |||
1302 1303 1304 1305 1306 1307 1308 |
/*
* See if we can build the value at compile time...
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
TclNewObj(dictObj);
Tcl_IncrRefCount(dictObj);
| | | 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 |
/*
* See if we can build the value at compile time...
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
TclNewObj(dictObj);
Tcl_IncrRefCount(dictObj);
for (i=1 ; i<(int)parsePtr->numWords ; i+=2) {
TclNewObj(keyObj);
Tcl_IncrRefCount(keyObj);
if (!TclWordKnownAtCompileTime(tokenPtr, keyObj)) {
Tcl_DecrRefCount(keyObj);
Tcl_DecrRefCount(dictObj);
goto nonConstant;
}
|
| ︙ | ︙ | |||
1352 1353 1354 1355 1356 1357 1358 |
return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
PushStringLiteral(envPtr, "");
Emit14Inst( INST_STORE_SCALAR, worker, envPtr);
TclEmitOpcode( INST_POP, envPtr);
tokenPtr = TokenAfter(parsePtr->tokenPtr);
| | | 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 |
return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
PushStringLiteral(envPtr, "");
Emit14Inst( INST_STORE_SCALAR, worker, envPtr);
TclEmitOpcode( INST_POP, envPtr);
tokenPtr = TokenAfter(parsePtr->tokenPtr);
for (i=1 ; i<(int)parsePtr->numWords ; i+=2) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, i+1);
tokenPtr = TokenAfter(tokenPtr);
TclEmitInstInt4( INST_DICT_SET, 1, envPtr);
TclEmitInt4( worker, envPtr);
TclAdjustStackDepth(-1, envPtr);
|
| ︙ | ︙ | |||
1387 1388 1389 1390 1391 1392 1393 |
/*
* Deal with some special edge cases. Note that in the case with one
* argument, the only thing to do is to verify the dict-ness.
*/
/* TODO: Consider support for compiling expanded args. (less likely) */
| | | 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 |
/*
* Deal with some special edge cases. Note that in the case with one
* argument, the only thing to do is to verify the dict-ness.
*/
/* TODO: Consider support for compiling expanded args. (less likely) */
if ((int)parsePtr->numWords < 2) {
PushStringLiteral(envPtr, "");
return TCL_OK;
} else if (parsePtr->numWords == 2) {
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_DICT_VERIFY, envPtr);
|
| ︙ | ︙ | |||
1429 1430 1431 1432 1433 1434 1435 |
/*
* For each of the remaining dictionaries...
*/
outLoop = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
TclEmitInstInt4( INST_BEGIN_CATCH4, outLoop, envPtr);
ExceptionRangeStarts(envPtr, outLoop);
| | | 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 |
/*
* For each of the remaining dictionaries...
*/
outLoop = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
TclEmitInstInt4( INST_BEGIN_CATCH4, outLoop, envPtr);
ExceptionRangeStarts(envPtr, outLoop);
for (i=2 ; i<(int)parsePtr->numWords ; i++) {
/*
* Get the dictionary, and merge its pairs into the first dict (using
* a small loop).
*/
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, i);
|
| ︙ | ︙ | |||
1524 1525 1526 1527 1528 1529 1530 |
* construct a new dictionary with the loop
* body result. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr;
int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange;
int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset;
| > | | 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 |
* construct a new dictionary with the loop
* body result. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr;
int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange;
int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset;
size_t numVars;
int endTargetOffset;
int collectVar = -1; /* Index of temp var holding the result
* dict. */
const char **argv;
Tcl_DString buffer;
/*
* There must be three arguments after the command.
|
| ︙ | ︙ | |||
1756 1757 1758 1759 1760 1761 1762 |
DictUpdateInfo *duiPtr;
JumpFixup jumpFixup;
/*
* There must be at least one argument after the command.
*/
| | | | 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 |
DictUpdateInfo *duiPtr;
JumpFixup jumpFixup;
/*
* There must be at least one argument after the command.
*/
if ((int)parsePtr->numWords < 5) {
return TCL_ERROR;
}
/*
* Parse the command. Expect the following:
* dict update <lit(eral)> <any> <lit> ?<any> <lit> ...? <lit>
*/
if (((int)parsePtr->numWords - 1) & 1) {
return TCL_ERROR;
}
numVars = (parsePtr->numWords - 3) / 2;
/*
* The dictionary variable must be a local scalar that is knowable at
* compile time; anything else exceeds the complexity of the opcode. So
|
| ︙ | ︙ | |||
1788 1789 1790 1791 1792 1793 1794 |
/*
* Assemble the instruction metadata. This is complex enough that it is
* represented as auxData; it holds an ordered list of variable indices
* that are to be used.
*/
| | | | 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 |
/*
* Assemble the instruction metadata. This is complex enough that it is
* represented as auxData; it holds an ordered list of variable indices
* that are to be used.
*/
duiPtr = (DictUpdateInfo *)Tcl_Alloc(offsetof(DictUpdateInfo, varIndices) + sizeof(size_t) * numVars);
duiPtr->length = numVars;
keyTokenPtrs = (Tcl_Token **)TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars);
tokenPtr = TokenAfter(dictVarTokenPtr);
for (i=0 ; i<numVars ; i++) {
/*
* Put keys to one side for later compilation to bytecode.
*/
keyTokenPtrs[i] = tokenPtr;
tokenPtr = TokenAfter(tokenPtr);
/*
* Stash the index in the auxiliary data (if it is indeed a local
* scalar that is resolvable at compile-time).
*/
duiPtr->varIndices[i] = LocalScalarFromToken(tokenPtr, envPtr);
if (duiPtr->varIndices[i] == TCL_INDEX_NONE) {
goto failedUpdateInfoAssembly;
}
tokenPtr = TokenAfter(tokenPtr);
}
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
goto failedUpdateInfoAssembly;
}
|
| ︙ | ︙ | |||
1908 1909 1910 1911 1912 1913 1914 |
/*
* There must be at least two argument after the command. And we impose an
* (arbirary) safe limit; anyone exceeding it should stop worrying about
* speed quite so much. ;-)
*/
/* TODO: Consider support for compiling expanded args. */
| | | | | | 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 1946 1947 |
/*
* There must be at least two argument after the command. And we impose an
* (arbirary) safe limit; anyone exceeding it should stop worrying about
* speed quite so much. ;-)
*/
/* TODO: Consider support for compiling expanded args. */
if ((int)parsePtr->numWords<4 || (int)parsePtr->numWords>100) {
return TCL_ERROR;
}
/*
* Get the index of the local variable that we will be working with.
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr);
if (dictVarIndex < 0) {
return TclCompileBasicMin2ArgCmd(interp, parsePtr,cmdPtr, envPtr);
}
/*
* Produce the string to concatenate onto the dictionary entry.
*/
tokenPtr = TokenAfter(tokenPtr);
for (i=2 ; i<(int)parsePtr->numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
if ((int)parsePtr->numWords > 4) {
TclEmitInstInt1(INST_STR_CONCAT1, (int)parsePtr->numWords-3, envPtr);
}
/*
* Do the concatenation.
*/
TclEmitInstInt4(INST_DICT_APPEND, dictVarIndex, envPtr);
|
| ︙ | ︙ | |||
2009 2010 2011 2012 2013 2014 2015 |
const char *ptr, *end;
/*
* There must be at least one argument after the command.
*/
/* TODO: Consider support for compiling expanded args. */
| | | | 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 |
const char *ptr, *end;
/*
* There must be at least one argument after the command.
*/
/* TODO: Consider support for compiling expanded args. */
if ((int)parsePtr->numWords < 3) {
return TCL_ERROR;
}
/*
* Parse the command (trivially). Expect the following:
* dict with <any (varName)> ?<any> ...? <literal>
*/
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
tokenPtr = TokenAfter(varTokenPtr);
for (i=3 ; i<(int)parsePtr->numWords ; i++) {
tokenPtr = TokenAfter(tokenPtr);
}
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
|
| ︙ | ︙ | |||
2048 2049 2050 2051 2052 2053 2054 |
}
}
/*
* Determine if we're manipulating a dict in a simple local variable.
*/
| | | | | 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 |
}
}
/*
* Determine if we're manipulating a dict in a simple local variable.
*/
gotPath = ((int)parsePtr->numWords > 3);
dictVar = LocalScalarFromToken(varTokenPtr, envPtr);
/*
* Special case: an empty body means we definitely have no need to issue
* try-finally style code or to allocate local variable table entries for
* storing temporaries. Still need to do both INST_DICT_EXPAND and
* INST_DICT_RECOMBINE_* though, because we can't determine if we're free
* of traces.
*/
if (bodyIsEmpty) {
if (dictVar >= 0) {
if (gotPath) {
/*
* Case: Path into dict in LVT with empty body.
*/
tokenPtr = TokenAfter(varTokenPtr);
for (i=2 ; i<(int)parsePtr->numWords-1 ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4(INST_LIST, (int)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);
} else {
/*
* Case: Direct dict in LVT with empty body.
|
| ︙ | ︙ | |||
2094 2095 2096 2097 2098 2099 2100 |
} else {
if (gotPath) {
/*
* Case: Path into dict in non-simple var with empty body.
*/
tokenPtr = varTokenPtr;
| | | | 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 |
} else {
if (gotPath) {
/*
* Case: Path into dict in non-simple var with empty body.
*/
tokenPtr = varTokenPtr;
for (i=1 ; i<(int)parsePtr->numWords-1 ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4(INST_LIST, (int)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 {
/*
|
| ︙ | ︙ | |||
2149 2150 2151 2152 2153 2154 2155 |
if (dictVar == -1) {
CompileWord(envPtr, varTokenPtr, interp, 1);
Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr);
}
tokenPtr = TokenAfter(varTokenPtr);
if (gotPath) {
| | | | 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 |
if (dictVar == -1) {
CompileWord(envPtr, varTokenPtr, interp, 1);
Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr);
}
tokenPtr = TokenAfter(varTokenPtr);
if (gotPath) {
for (i=2 ; i<(int)parsePtr->numWords-1 ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4( INST_LIST, (int)parsePtr->numWords-3,envPtr);
Emit14Inst( INST_STORE_SCALAR, pathTmp, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
if (dictVar == -1) {
TclEmitOpcode( INST_LOAD_STK, envPtr);
} else {
Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr);
|
| ︙ | ︙ | |||
2215 2216 2217 2218 2219 2220 2221 |
ExceptionRangeTarget(envPtr, range, catchOffset);
TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
TclEmitOpcode( INST_END_CATCH, envPtr);
if (dictVar == -1) {
Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr);
}
| | | 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 |
ExceptionRangeTarget(envPtr, range, catchOffset);
TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
TclEmitOpcode( INST_END_CATCH, envPtr);
if (dictVar == -1) {
Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr);
}
if ((int)parsePtr->numWords > 3) {
Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr);
} else {
PushStringLiteral(envPtr, "");
}
Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr);
if (dictVar == -1) {
TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr);
|
| ︙ | ︙ | |||
2262 2263 2264 2265 2266 2267 2268 | * FreeDictUpdateInfo: releases memory * PrintDictUpdateInfo: none * DisassembleDictUpdateInfo: none * *---------------------------------------------------------------------- */ | | | | | | | | | 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 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 |
* FreeDictUpdateInfo: releases memory
* PrintDictUpdateInfo: none
* DisassembleDictUpdateInfo: none
*
*----------------------------------------------------------------------
*/
static void *
DupDictUpdateInfo(
void *clientData)
{
DictUpdateInfo *dui1Ptr, *dui2Ptr;
size_t len;
dui1Ptr = (DictUpdateInfo *)clientData;
len = offsetof(DictUpdateInfo, varIndices) + sizeof(size_t) * dui1Ptr->length;
dui2Ptr = (DictUpdateInfo *)Tcl_Alloc(len);
memcpy(dui2Ptr, dui1Ptr, len);
return dui2Ptr;
}
static void
FreeDictUpdateInfo(
void *clientData)
{
Tcl_Free(clientData);
}
static void
PrintDictUpdateInfo(
void *clientData,
Tcl_Obj *appendObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(size_t))
{
DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData;
size_t i;
for (i=0 ; i<duiPtr->length ; i++) {
if (i) {
Tcl_AppendToObj(appendObj, ", ", -1);
}
Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", duiPtr->varIndices[i]);
}
}
static void
DisassembleDictUpdateInfo(
void *clientData,
Tcl_Obj *dictObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(size_t))
{
DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData;
size_t i;
Tcl_Obj *variables;
|
| ︙ | ︙ | |||
2354 2355 2356 2357 2358 2359 2360 |
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
/*
* General syntax: [error message ?errorInfo? ?errorCode?]
*/
| | | 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 |
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
/*
* General syntax: [error message ?errorInfo? ?errorCode?]
*/
if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 4) {
return TCL_ERROR;
}
/*
* Handle the message.
*/
|
| ︙ | ︙ | |||
2434 2435 2436 2437 2438 2439 2440 |
* TIP #280: Use the per-word line information of the current command.
*/
envPtr->line = envPtr->extCmdMapPtr->loc[
envPtr->extCmdMapPtr->nuloc-1].line[1];
firstWordPtr = TokenAfter(parsePtr->tokenPtr);
| | | 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 |
* TIP #280: Use the per-word line information of the current command.
*/
envPtr->line = envPtr->extCmdMapPtr->loc[
envPtr->extCmdMapPtr->nuloc-1].line[1];
firstWordPtr = TokenAfter(parsePtr->tokenPtr);
TclCompileExprWords(interp, firstWordPtr, (int)parsePtr->numWords-1, envPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileForCmd --
|
| ︙ | ︙ | |||
2684 2685 2686 2687 2688 2689 2690 |
Proc *procPtr = envPtr->procPtr;
ForeachInfo *infoPtr=NULL; /* Points to the structure describing this
* foreach command. Stored in a AuxData
* record in the ByteCode. */
Tcl_Token *tokenPtr, *bodyTokenPtr;
int jumpBackOffset, infoIndex, range;
| | > | | 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 |
Proc *procPtr = envPtr->procPtr;
ForeachInfo *infoPtr=NULL; /* Points to the structure describing this
* foreach command. Stored in a AuxData
* record in the ByteCode. */
Tcl_Token *tokenPtr, *bodyTokenPtr;
int jumpBackOffset, infoIndex, range;
int numWords, numLists, i, code = TCL_OK;
size_t j;
Tcl_Obj *varListObj = NULL;
/*
* If the foreach command isn't in a procedure, don't compile it inline:
* the payoff is too small.
*/
if (procPtr == NULL) {
return TCL_ERROR;
}
numWords = (int)parsePtr->numWords;
if ((numWords < 4) || (numWords%2 != 0)) {
return TCL_ERROR;
}
/*
* Bail out if the body requires substitutions in order to ensure correct
* behaviour. [Bug 219166]
|
| ︙ | ︙ | |||
2736 2737 2738 2739 2740 2741 2742 |
*/
TclNewObj(varListObj);
for (i = 0, tokenPtr = parsePtr->tokenPtr;
i < numWords-1;
i++, tokenPtr = TokenAfter(tokenPtr)) {
ForeachVarList *varListPtr;
| | | | | 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 |
*/
TclNewObj(varListObj);
for (i = 0, tokenPtr = parsePtr->tokenPtr;
i < numWords-1;
i++, tokenPtr = TokenAfter(tokenPtr)) {
ForeachVarList *varListPtr;
size_t numVars;
if (i%2 != 1) {
continue;
}
/*
* If the variable list is empty, we can enter an infinite loop when
* the interpreted version would not. Take care to ensure this does
* not happen. [Bug 1671138]
*/
if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) ||
TCL_OK != TclListObjLengthM(NULL, varListObj, &numVars) ||
numVars == 0) {
code = TCL_ERROR;
goto done;
}
varListPtr = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes)
+ numVars * sizeof(size_t));
varListPtr->numVars = numVars;
infoPtr->varLists[i/2] = varListPtr;
infoPtr->numLists++;
for (j = 0; j < numVars; j++) {
Tcl_Obj *varNameObj;
const char *bytes;
|
| ︙ | ︙ | |||
2883 2884 2885 2886 2887 2888 2889 | * original ForeachInfo structure pointed to any ForeachVarList records, * these structures are also copied and pointers to them are stored in * the new ForeachInfo record. * *---------------------------------------------------------------------- */ | | | | | 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 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 |
* original ForeachInfo structure pointed to any ForeachVarList records,
* these structures are also copied and pointers to them are stored in
* the new ForeachInfo record.
*
*----------------------------------------------------------------------
*/
static void *
DupForeachInfo(
void *clientData) /* The foreach command's compilation auxiliary
* data to duplicate. */
{
ForeachInfo *srcPtr = (ForeachInfo *)clientData;
ForeachInfo *dupPtr;
ForeachVarList *srcListPtr, *dupListPtr;
int numVars, i, j, numLists = srcPtr->numLists;
dupPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists)
+ numLists * sizeof(ForeachVarList *));
dupPtr->numLists = numLists;
dupPtr->firstValueTemp = srcPtr->firstValueTemp;
dupPtr->loopCtTemp = srcPtr->loopCtTemp;
for (i = 0; i < numLists; i++) {
srcListPtr = srcPtr->varLists[i];
numVars = srcListPtr->numVars;
dupListPtr = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes)
+ numVars * sizeof(size_t));
dupListPtr->numVars = numVars;
for (j = 0; j < numVars; j++) {
dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j];
}
dupPtr->varLists[i] = dupListPtr;
}
return dupPtr;
|
| ︙ | ︙ | |||
2934 2935 2936 2937 2938 2939 2940 | * ForeachInfo structure. * *---------------------------------------------------------------------- */ static void FreeForeachInfo( | | | 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 |
* ForeachInfo structure.
*
*----------------------------------------------------------------------
*/
static void
FreeForeachInfo(
void *clientData) /* The foreach command's compilation auxiliary
* data to free. */
{
ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *listPtr;
size_t i, numLists = infoPtr->numLists;
for (i = 0; i < numLists; i++) {
|
| ︙ | ︙ | |||
2967 2968 2969 2970 2971 2972 2973 | * None. * *---------------------------------------------------------------------- */ static void PrintForeachInfo( | | | 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 |
* None.
*
*----------------------------------------------------------------------
*/
static void
PrintForeachInfo(
void *clientData,
Tcl_Obj *appendObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(size_t))
{
ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
size_t i, j;
|
| ︙ | ︙ | |||
2998 2999 3000 3001 3002 3003 3004 |
Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%" TCL_Z_MODIFIER "u\t[",
(infoPtr->firstValueTemp + i));
varsPtr = infoPtr->varLists[i];
for (j=0 ; j<varsPtr->numVars ; j++) {
if (j) {
Tcl_AppendToObj(appendObj, ", ", -1);
}
| | | | | | | | 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 |
Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%" TCL_Z_MODIFIER "u\t[",
(infoPtr->firstValueTemp + i));
varsPtr = infoPtr->varLists[i];
for (j=0 ; j<varsPtr->numVars ; j++) {
if (j) {
Tcl_AppendToObj(appendObj, ", ", -1);
}
Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u",
varsPtr->varIndexes[j]);
}
Tcl_AppendToObj(appendObj, "]", -1);
}
}
static void
PrintNewForeachInfo(
void *clientData,
Tcl_Obj *appendObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(size_t))
{
ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
size_t i, j;
Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+" TCL_Z_MODIFIER "d, vars=",
infoPtr->loopCtTemp);
for (i=0 ; i<infoPtr->numLists ; i++) {
if (i) {
Tcl_AppendToObj(appendObj, ",", -1);
}
Tcl_AppendToObj(appendObj, "[", -1);
varsPtr = infoPtr->varLists[i];
for (j=0 ; j<varsPtr->numVars ; j++) {
if (j) {
Tcl_AppendToObj(appendObj, ",", -1);
}
Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u",
varsPtr->varIndexes[j]);
}
Tcl_AppendToObj(appendObj, "]", -1);
}
}
static void
DisassembleForeachInfo(
void *clientData,
Tcl_Obj *dictObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(size_t))
{
ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
size_t i, j;
|
| ︙ | ︙ | |||
3084 3085 3086 3087 3088 3089 3090 |
Tcl_ListObjAppendElement(NULL, objPtr, innerPtr);
}
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr);
}
static void
DisassembleNewForeachInfo(
| | | 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 |
Tcl_ListObjAppendElement(NULL, objPtr, innerPtr);
}
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr);
}
static void
DisassembleNewForeachInfo(
void *clientData,
Tcl_Obj *dictObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(size_t))
{
ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
size_t i, j;
|
| ︙ | ︙ | |||
3156 3157 3158 3159 3160 3161 3162 |
int i, j;
size_t len;
/*
* Don't handle any guaranteed-error cases.
*/
| | | | | | 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 |
int i, j;
size_t len;
/*
* Don't handle any guaranteed-error cases.
*/
if ((int)parsePtr->numWords < 2) {
return TCL_ERROR;
}
/*
* Check if the argument words are all compile-time-known literals; that's
* a case we can handle by compiling to a constant.
*/
TclNewObj(formatObj);
Tcl_IncrRefCount(formatObj);
tokenPtr = TokenAfter(tokenPtr);
if (!TclWordKnownAtCompileTime(tokenPtr, formatObj)) {
Tcl_DecrRefCount(formatObj);
return TCL_ERROR;
}
objv = (Tcl_Obj **)Tcl_Alloc(((int)parsePtr->numWords-2) * sizeof(Tcl_Obj *));
for (i=0 ; i+2 < (int)parsePtr->numWords ; i++) {
tokenPtr = TokenAfter(tokenPtr);
TclNewObj(objv[i]);
Tcl_IncrRefCount(objv[i]);
if (!TclWordKnownAtCompileTime(tokenPtr, objv[i])) {
goto checkForStringConcatCase;
}
}
/*
* Everything is a literal, so the result is constant too (or an error if
* the format is broken). Do the format now.
*/
tmpObj = Tcl_Format(interp, TclGetString(formatObj),
(int)parsePtr->numWords-2, objv);
for (; --i>=0 ;) {
Tcl_DecrRefCount(objv[i]);
}
Tcl_Free(objv);
Tcl_DecrRefCount(formatObj);
if (tmpObj == NULL) {
TclCompileSyntaxError(interp, envPtr);
|
| ︙ | ︙ | |||
3250 3251 3252 3253 3254 3255 3256 |
}
}
/*
* Check if the number of things to concatenate will fit in a byte.
*/
| | | 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 |
}
}
/*
* Check if the number of things to concatenate will fit in a byte.
*/
if (i+2 != (int)parsePtr->numWords || i > 125) {
Tcl_DecrRefCount(formatObj);
return TCL_ERROR;
}
/*
* Generate the pushes of the things to concatenate, a sequence of
* literals and compiled tokens (of which at least one is non-literal or
|
| ︙ | ︙ | |||
3340 3341 3342 3343 3344 3345 3346 | * Get the index into the table of compiled locals that corresponds * to a local scalar variable name. * * Results: * Returns the non-negative integer index value into the table of * compiled locals corresponding to a local scalar variable name. * If the arguments passed in do not identify a local scalar variable | | | | | | 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 |
* Get the index into the table of compiled locals that corresponds
* to a local scalar variable name.
*
* Results:
* Returns the non-negative integer index value into the table of
* compiled locals corresponding to a local scalar variable name.
* If the arguments passed in do not identify a local scalar variable
* then return TCL_INDEX_NONE.
*
* Side effects:
* May add an entry into the table of compiled locals.
*
*----------------------------------------------------------------------
*/
size_t
TclLocalScalarFromToken(
Tcl_Token *tokenPtr,
CompileEnv *envPtr)
{
int isScalar, index;
TclPushVarName(NULL, tokenPtr, envPtr, TCL_NO_ELEMENT, &index, &isScalar);
if (!isScalar) {
index = -1;
}
return index;
}
size_t
TclLocalScalar(
const char *bytes,
size_t numBytes,
CompileEnv *envPtr)
{
Tcl_Token token[2] = {{TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1},
{TCL_TOKEN_TEXT, NULL, 0, 0}};
|
| ︙ | ︙ |
Changes to generic/tclCompCmdsGR.c.
| ︙ | ︙ | |||
91 92 93 94 95 96 97 |
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr;
int localIndex, numWords, i;
/* TODO: Consider support for compiling expanded args. */
| | | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 |
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr;
int localIndex, numWords, i;
/* TODO: Consider support for compiling expanded args. */
numWords = (int)parsePtr->numWords;
if (numWords < 2) {
return TCL_ERROR;
}
/*
* 'global' has no effect outside of proc bodies; handle that at runtime
*/
|
| ︙ | ︙ | |||
177 178 179 180 181 182 183 |
* test when its target PC is determined. */
JumpFixupArray jumpEndFixupArray;
/* Used to fix the jump after each "then" body
* to the end of the "if" when that PC is
* determined. */
Tcl_Token *tokenPtr, *testTokenPtr;
int jumpIndex = 0; /* Avoid compiler warning. */
| | | | | 177 178 179 180 181 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 |
* test when its target PC is determined. */
JumpFixupArray jumpEndFixupArray;
/* Used to fix the jump after each "then" body
* to the end of the "if" when that PC is
* determined. */
Tcl_Token *tokenPtr, *testTokenPtr;
int jumpIndex = 0; /* Avoid compiler warning. */
size_t numBytes, j;
int jumpFalseDist, numWords, wordIdx, code;
const char *word;
int realCond = 1; /* Set to 0 for static conditions:
* "if 0 {..}" */
int boolVal; /* Value of static condition. */
int compileScripts = 1;
/*
* Only compile the "if" command if all arguments are simple words, in
* order to insure correct substitution [Bug 219166]
*/
tokenPtr = parsePtr->tokenPtr;
wordIdx = 0;
numWords = (int)parsePtr->numWords;
for (wordIdx = 0; wordIdx < numWords; wordIdx++) {
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(tokenPtr);
}
|
| ︙ | ︙ | |||
843 844 845 846 847 848 849 |
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *valueTokenPtr;
int isScalar, localIndex, numWords, i;
/* TODO: Consider support for compiling expanded args. */
| | | 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 |
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *valueTokenPtr;
int isScalar, localIndex, numWords, i;
/* TODO: Consider support for compiling expanded args. */
numWords = (int)parsePtr->numWords;
if (numWords < 3) {
return TCL_ERROR;
}
if (numWords != 3 || envPtr->procPtr == NULL) {
goto lappendMultiple;
}
|
| ︙ | ︙ | |||
957 958 959 960 961 962 963 |
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int isScalar, localIndex, numWords, idx;
| | | 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 |
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int isScalar, localIndex, numWords, idx;
numWords = (int)parsePtr->numWords;
/*
* Check for command syntax error, but we'll punt that to runtime.
*/
if (numWords < 3) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
1058 1059 1060 1061 1062 1063 1064 |
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *idxTokenPtr, *valTokenPtr;
| | | 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 |
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *idxTokenPtr, *valTokenPtr;
int i, idx, numWords = (int)parsePtr->numWords;
/*
* Quit if not enough args.
*/
/* TODO: Consider support for compiling expanded args. */
if (numWords <= 1) {
|
| ︙ | ︙ | |||
1165 1166 1167 1168 1169 1170 1171 |
}
/*
* Test if all arguments are compile-time known. If they are, we can
* implement with a simple push.
*/
| | | 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 |
}
/*
* Test if all arguments are compile-time known. If they are, we can
* implement with a simple push.
*/
numWords = (int)parsePtr->numWords;
valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
TclNewObj(listObj);
for (i = 1; i < numWords && listObj != NULL; i++) {
TclNewObj(objPtr);
if (TclWordKnownAtCompileTime(valueTokenPtr, objPtr)) {
(void) Tcl_ListObjAppendElement(NULL, listObj, objPtr);
} else {
|
| ︙ | ︙ | |||
1188 1189 1190 1191 1192 1193 1194 |
return TCL_OK;
}
/*
* Push the all values onto the stack.
*/
| | | 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 |
return TCL_OK;
}
/*
* Push the all values onto the stack.
*/
numWords = (int)parsePtr->numWords;
valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
concat = build = 0;
for (i = 1; i < numWords; i++) {
if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD && build > 0) {
TclEmitInstInt4( INST_LIST, build, envPtr);
if (concat) {
TclEmitOpcode( INST_LIST_CONCAT, envPtr);
|
| ︙ | ︙ | |||
1355 1356 1357 1358 1359 1360 1361 |
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *listTokenPtr;
int idx, i;
| | | 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 |
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *listTokenPtr;
int idx, i;
if ((int)parsePtr->numWords < 3) {
return TCL_ERROR;
}
listTokenPtr = TokenAfter(parsePtr->tokenPtr);
/*
* Parse the index. Will only compile if it is constant and not an
* _integer_ less than zero (since we reserve negative indices here for
|
| ︙ | ︙ | |||
1394 1395 1396 1397 1398 1399 1400 |
CompileWord(envPtr, listTokenPtr, interp, 1);
if (parsePtr->numWords == 3) {
TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
TclEmitInt4( (int)TCL_INDEX_END, envPtr);
return TCL_OK;
}
| | | 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 |
CompileWord(envPtr, listTokenPtr, interp, 1);
if (parsePtr->numWords == 3) {
TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
TclEmitInt4( (int)TCL_INDEX_END, envPtr);
return TCL_OK;
}
for (i=3 ; i<(int)parsePtr->numWords ; i++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, i);
}
TclEmitInstInt4( INST_LIST, i - 3, envPtr);
if (idx == (int)TCL_INDEX_START) {
TclEmitInstInt4( INST_REVERSE, 2, envPtr);
|
| ︙ | ︙ | |||
1458 1459 1460 1461 1462 1463 1464 |
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *listTokenPtr;
int idx1, idx2, i;
int emptyPrefix=1, suffixStart = 0;
| | | 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 |
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *listTokenPtr;
int idx1, idx2, i;
int emptyPrefix=1, suffixStart = 0;
if ((int)parsePtr->numWords < 4) {
return TCL_ERROR;
}
listTokenPtr = TokenAfter(parsePtr->tokenPtr);
tokenPtr = TokenAfter(listTokenPtr);
if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE,
&idx1) != TCL_OK) {
|
| ︙ | ︙ | |||
1506 1507 1508 1509 1510 1511 1512 |
/* All paths start with computing/pushing the original value. */
CompileWord(envPtr, listTokenPtr, interp, 1);
/*
* Push all the replacement values next so any errors raised in
* creating them get raised first.
*/
| | | | 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 |
/* All paths start with computing/pushing the original value. */
CompileWord(envPtr, listTokenPtr, interp, 1);
/*
* Push all the replacement values next so any errors raised in
* creating them get raised first.
*/
if ((int)parsePtr->numWords > 4) {
/* Push the replacement arguments */
tokenPtr = TokenAfter(tokenPtr);
for (i=4 ; i<(int)parsePtr->numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
/* Make a list of them... */
TclEmitInstInt4( INST_LIST, i - 4, envPtr);
|
| ︙ | ︙ | |||
1630 1631 1632 1633 1634 1635 1636 |
int i;
/*
* Check argument count.
*/
/* TODO: Consider support for compiling expanded args. */
| | | 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 |
int i;
/*
* Check argument count.
*/
/* TODO: Consider support for compiling expanded args. */
if ((int)parsePtr->numWords < 3) {
/*
* Fail at run time, not in compilation.
*/
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1654 1655 1656 1657 1658 1659 1660 |
PushVarNameWord(interp, varTokenPtr, envPtr, 0,
&localIndex, &isScalar, 1);
/*
* Push the "index" args and the new element value.
*/
| | | 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 |
PushVarNameWord(interp, varTokenPtr, envPtr, 0,
&localIndex, &isScalar, 1);
/*
* Push the "index" args and the new element value.
*/
for (i=2 ; i<(int)parsePtr->numWords ; ++i) {
varTokenPtr = TokenAfter(varTokenPtr);
CompileWord(envPtr, varTokenPtr, interp, i);
}
/*
* Duplicate the variable name if it's been pushed.
*/
|
| ︙ | ︙ | |||
1939 1940 1941 1942 1943 1944 1945 |
return TCL_ERROR;
}
/*
* Only compile [namespace upvar ...]: needs an even number of args, >=4
*/
| | | 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 |
return TCL_ERROR;
}
/*
* Only compile [namespace upvar ...]: needs an even number of args, >=4
*/
numWords = (int)parsePtr->numWords;
if ((numWords % 2) || (numWords < 4)) {
return TCL_ERROR;
}
/*
* Push the namespace
*/
|
| ︙ | ︙ | |||
1991 1992 1993 1994 1995 1996 1997 |
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *opt;
int idx;
| | | 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 |
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *opt;
int idx;
if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 3) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
idx = 1;
/*
* If there's an option, check that it's "-command". We don't handle
|
| ︙ | ︙ | |||
2064 2065 2066 2067 2068 2069 2070 |
/*
* We are only interested in compiling simple regexp cases. Currently
* supported compile cases are:
* regexp ?-nocase? ?--? staticString $var
* regexp ?-nocase? ?--? {^staticString$} $var
*/
| | | | 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 |
/*
* We are only interested in compiling simple regexp cases. Currently
* supported compile cases are:
* regexp ?-nocase? ?--? staticString $var
* regexp ?-nocase? ?--? {^staticString$} $var
*/
if ((int)parsePtr->numWords < 3) {
return TCL_ERROR;
}
simple = 0;
nocase = 0;
sawLast = 0;
varTokenPtr = parsePtr->tokenPtr;
/*
* We only look for -nocase and -- as options. Everything else gets pushed
* to runtime execution. This is different than regexp's runtime option
* handling, but satisfies our stricter needs.
*/
for (i = 1; i < (int)parsePtr->numWords - 2; i++) {
varTokenPtr = TokenAfter(varTokenPtr);
if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
/*
* Not a simple string, so punt to runtime.
*/
return TCL_ERROR;
|
| ︙ | ︙ | |||
2105 2106 2107 2108 2109 2110 2111 |
* Not an option we recognize.
*/
return TCL_ERROR;
}
}
| | | 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 |
* Not an option we recognize.
*/
return TCL_ERROR;
}
}
if (((int)parsePtr->numWords - i) != 2) {
/*
* We don't support capturing to variables.
*/
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2158 2159 2160 2161 2162 2163 2164 |
simple = 1;
PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
}
}
if (!simple) {
| | | | 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 |
simple = 1;
PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
}
}
if (!simple) {
CompileWord(envPtr, varTokenPtr, interp, (int)parsePtr->numWords - 2);
}
/*
* Push the string arg.
*/
varTokenPtr = TokenAfter(varTokenPtr);
CompileWord(envPtr, varTokenPtr, interp, (int)parsePtr->numWords - 1);
if (simple) {
if (exact && !nocase) {
TclEmitOpcode( INST_STR_EQ, envPtr);
} else {
TclEmitInstInt1( INST_STR_MATCH, nocase, envPtr);
}
|
| ︙ | ︙ | |||
2243 2244 2245 2246 2247 2248 2249 |
Tcl_Token *tokenPtr, *stringTokenPtr;
Tcl_Obj *patternObj = NULL, *replacementObj = NULL;
Tcl_DString pattern;
const char *bytes;
int exact, quantified, result = TCL_ERROR;
size_t len;
| | | 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 |
Tcl_Token *tokenPtr, *stringTokenPtr;
Tcl_Obj *patternObj = NULL, *replacementObj = NULL;
Tcl_DString pattern;
const char *bytes;
int exact, quantified, result = TCL_ERROR;
size_t len;
if ((int)parsePtr->numWords < 5 || (int)parsePtr->numWords > 6) {
return TCL_ERROR;
}
/*
* Parse the "-all", which must be the first argument (other options not
* supported, non-"-all" substitution we can't compile).
*/
|
| ︙ | ︙ | |||
2350 2351 2352 2353 2354 2355 2356 |
*/
result = TCL_OK;
bytes = Tcl_DStringValue(&pattern) + 1;
PushLiteral(envPtr, bytes, len);
bytes = Tcl_GetStringFromObj(replacementObj, &len);
PushLiteral(envPtr, bytes, len);
| | | 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 |
*/
result = TCL_OK;
bytes = Tcl_DStringValue(&pattern) + 1;
PushLiteral(envPtr, bytes, len);
bytes = Tcl_GetStringFromObj(replacementObj, &len);
PushLiteral(envPtr, bytes, len);
CompileWord(envPtr, stringTokenPtr, interp, (int)parsePtr->numWords - 2);
TclEmitOpcode( INST_STR_MAP, envPtr);
done:
Tcl_DStringFree(&pattern);
if (patternObj) {
Tcl_DecrRefCount(patternObj);
}
|
| ︙ | ︙ | |||
2395 2396 2397 2398 2399 2400 2401 |
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
/*
* General syntax: [return ?-option value ...? ?result?]
* An even number of words means an explicit result argument is present.
*/
| | > | | 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 |
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
/*
* General syntax: [return ?-option value ...? ?result?]
* An even number of words means an explicit result argument is present.
*/
int level, code, objc, status = TCL_OK;
size_t size;
int numWords = (int)parsePtr->numWords;
int explicitResult = (0 == (numWords % 2));
int numOptionWords = numWords - 1 - explicitResult;
Tcl_Obj *returnOpts, **objv;
Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
/*
* Check for special case which can always be compiled:
|
| ︙ | ︙ | |||
2505 2506 2507 2508 2509 2510 2511 |
int index = envPtr->exceptArrayNext - 1;
int enclosingCatch = 0;
while (index >= 0) {
ExceptionRange range = envPtr->exceptArrayPtr[index];
if ((range.type == CATCH_EXCEPTION_RANGE)
| | | 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 |
int index = envPtr->exceptArrayNext - 1;
int enclosingCatch = 0;
while (index >= 0) {
ExceptionRange range = envPtr->exceptArrayPtr[index];
if ((range.type == CATCH_EXCEPTION_RANGE)
&& (range.catchOffset == TCL_INDEX_NONE)) {
enclosingCatch = 1;
break;
}
index--;
}
if (!enclosingCatch) {
/*
|
| ︙ | ︙ | |||
2650 2651 2652 2653 2654 2655 2656 |
int localIndex, numWords, i;
Tcl_Obj *objPtr;
if (envPtr->procPtr == NULL) {
return TCL_ERROR;
}
| | | 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 |
int localIndex, numWords, i;
Tcl_Obj *objPtr;
if (envPtr->procPtr == NULL) {
return TCL_ERROR;
}
numWords = (int)parsePtr->numWords;
if (numWords < 3) {
return TCL_ERROR;
}
/*
* Push the frame index if it is known at compile time
*/
|
| ︙ | ︙ | |||
2751 2752 2753 2754 2755 2756 2757 |
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *valueTokenPtr;
int localIndex, numWords, i;
| | | 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 |
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *valueTokenPtr;
int localIndex, numWords, i;
numWords = (int)parsePtr->numWords;
if (numWords < 2) {
return TCL_ERROR;
}
/*
* Bail out if not compiling a proc body
*/
|
| ︙ | ︙ | |||
2925 2926 2927 2928 2929 2930 2931 |
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int i;
| | | | | | 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 |
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int i;
if ((int)parsePtr->numWords > 255) {
return TCL_ERROR;
}
for (i=0 ; i<(int)parsePtr->numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt1( INST_TCLOO_NEXT, i, envPtr);
return TCL_OK;
}
int
TclCompileObjectNextToCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int i;
if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 255) {
return TCL_ERROR;
}
for (i=0 ; i<(int)parsePtr->numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt1( INST_TCLOO_NEXT_CLASS, i, envPtr);
return TCL_OK;
}
|
| ︙ | ︙ |
Changes to generic/tclCompCmdsSZ.c.
| ︙ | ︙ | |||
569 570 571 572 573 574 575 |
* 1. Character classes
* 2. Booleans
* 3. Integers
* 4. Floats
* 5. Lists
*/
| | | 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 |
* 1. Character classes
* 2. Booleans
* 3. Integers
* 4. Floats
* 5. Lists
*/
CompileWord(envPtr, tokenPtr, interp, (int)parsePtr->numWords-1);
switch (t) {
case STR_IS_ALNUM:
strClassType = STR_CLASS_ALNUM;
goto compileStrClass;
case STR_IS_ALPHA:
strClassType = STR_CLASS_ALPHA;
|
| ︙ | ︙ | |||
893 894 895 896 897 898 899 | * something with backslashes). Just push the actual character (not * byte) length. */ char buf[TCL_INTEGER_SPACE]; size_t len = Tcl_GetCharLength(objPtr); | | | 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 |
* something with backslashes). Just push the actual character (not
* byte) length.
*/
char buf[TCL_INTEGER_SPACE];
size_t len = Tcl_GetCharLength(objPtr);
len = sprintf(buf, "%" TCL_Z_MODIFIER "u", len);
PushLiteral(envPtr, buf, len);
} else {
SetLineInformation(1);
CompileTokens(envPtr, tokenPtr, interp);
TclEmitOpcode(INST_STR_LEN, envPtr);
}
TclDecrRefCount(objPtr);
|
| ︙ | ︙ | |||
917 918 919 920 921 922 923 |
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *mapTokenPtr, *stringTokenPtr;
Tcl_Obj *mapObj, **objv;
const char *bytes;
| < | | 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 |
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *mapTokenPtr, *stringTokenPtr;
Tcl_Obj *mapObj, **objv;
const char *bytes;
size_t len, slen;
/*
* We only handle the case:
*
* string map {foo bar} $thing
*
* That is, a literal two-element list (doesn't need to be brace-quoted,
|
| ︙ | ︙ | |||
940 941 942 943 944 945 946 |
mapTokenPtr = TokenAfter(parsePtr->tokenPtr);
stringTokenPtr = TokenAfter(mapTokenPtr);
TclNewObj(mapObj);
Tcl_IncrRefCount(mapObj);
if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) {
Tcl_DecrRefCount(mapObj);
return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
| | | 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 |
mapTokenPtr = TokenAfter(parsePtr->tokenPtr);
stringTokenPtr = TokenAfter(mapTokenPtr);
TclNewObj(mapObj);
Tcl_IncrRefCount(mapObj);
if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) {
Tcl_DecrRefCount(mapObj);
return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
} else if (TclListObjGetElementsM(NULL, mapObj, &len, &objv) != TCL_OK) {
Tcl_DecrRefCount(mapObj);
return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
} else if (len != 2) {
Tcl_DecrRefCount(mapObj);
return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
|
| ︙ | ︙ | |||
1055 1056 1057 1058 1059 1060 1061 |
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *valueTokenPtr;
int first, last;
| | | 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 |
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *valueTokenPtr;
int first, last;
if ((int)parsePtr->numWords < 4 || (int)parsePtr->numWords > 5) {
return TCL_ERROR;
}
/* Bytecode to compute/push string argument being replaced */
valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, valueTokenPtr, interp, 1);
|
| ︙ | ︙ | |||
1516 1517 1518 1519 1520 1521 1522 |
void
TclSubstCompile(
Tcl_Interp *interp,
const char *bytes,
size_t numBytes,
int flags,
| | | > | 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 |
void
TclSubstCompile(
Tcl_Interp *interp,
const char *bytes,
size_t numBytes,
int flags,
size_t line,
CompileEnv *envPtr)
{
Tcl_Token *endTokenPtr, *tokenPtr;
int breakOffset = 0, count = 0;
size_t bline = line;
Tcl_Parse parse;
Tcl_InterpState state = NULL;
TclSubstParse(interp, bytes, numBytes, flags, &parse, &state);
if (state != NULL) {
Tcl_ResetResult(interp);
}
|
| ︙ | ︙ | |||
1942 1943 1944 1945 1946 1947 1948 |
* causes a crash during exception handling). When multiple tokens are
* available at this point, this is pretty easy.
*/
if (numWords == 1) {
const char *bytes;
size_t maxLen, numBytes;
| | | 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 |
* causes a crash during exception handling). When multiple tokens are
* available at this point, this is pretty easy.
*/
if (numWords == 1) {
const char *bytes;
size_t maxLen, numBytes;
size_t bline; /* TIP #280: line of the pattern/action list,
* and start of list for when tracking the
* location. This list comes immediately after
* the value we switch on. */
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2431 2432 2433 2434 2435 2436 2437 |
Tcl_DStringValue(&buffer), &isNew);
if (isNew) {
/*
* First time we've encountered this match clause, so it must
* point to here.
*/
| | | 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 |
Tcl_DStringValue(&buffer), &isNew);
if (isNew) {
/*
* First time we've encountered this match clause, so it must
* point to here.
*/
Tcl_SetHashValue(hPtr, INT2PTR(CurrentOffset(envPtr) - jumpLocation));
}
Tcl_DStringFree(&buffer);
} else {
/*
* This is a default clause, so patch up the fallthrough from the
* INST_JUMP_TABLE instruction to here.
*/
|
| ︙ | ︙ | |||
2551 2552 2553 2554 2555 2556 2557 | * FreeJumptableInfo: releases memory * PrintJumptableInfo: none * DisassembleJumptableInfo: none * *---------------------------------------------------------------------- */ | | | | | | 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 |
* FreeJumptableInfo: releases memory
* PrintJumptableInfo: none
* DisassembleJumptableInfo: none
*
*----------------------------------------------------------------------
*/
static void *
DupJumptableInfo(
void *clientData)
{
JumptableInfo *jtPtr = (JumptableInfo *)clientData;
JumptableInfo *newJtPtr = (JumptableInfo *)Tcl_Alloc(sizeof(JumptableInfo));
Tcl_HashEntry *hPtr, *newHPtr;
Tcl_HashSearch search;
int isNew;
Tcl_InitHashTable(&newJtPtr->hashTable, TCL_STRING_KEYS);
hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
while (hPtr != NULL) {
newHPtr = Tcl_CreateHashEntry(&newJtPtr->hashTable,
Tcl_GetHashKey(&jtPtr->hashTable, hPtr), &isNew);
Tcl_SetHashValue(newHPtr, Tcl_GetHashValue(hPtr));
}
return newJtPtr;
}
static void
FreeJumptableInfo(
void *clientData)
{
JumptableInfo *jtPtr = (JumptableInfo *)clientData;
Tcl_DeleteHashTable(&jtPtr->hashTable);
Tcl_Free(jtPtr);
}
static void
PrintJumptableInfo(
void *clientData,
Tcl_Obj *appendObj,
TCL_UNUSED(ByteCode *),
size_t pcOffset)
{
JumptableInfo *jtPtr = (JumptableInfo *)clientData;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
|
| ︙ | ︙ | |||
2612 2613 2614 2615 2616 2617 2618 |
Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %" TCL_Z_MODIFIER "u",
keyPtr, pcOffset + offset);
}
}
static void
DisassembleJumptableInfo(
| | | 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 |
Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %" TCL_Z_MODIFIER "u",
keyPtr, pcOffset + offset);
}
}
static void
DisassembleJumptableInfo(
void *clientData,
Tcl_Obj *dictObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(size_t))
{
JumptableInfo *jtPtr = (JumptableInfo *)clientData;
Tcl_Obj *mapping;
Tcl_HashEntry *hPtr;
|
| ︙ | ︙ | |||
2673 2674 2675 2676 2677 2678 2679 |
|| 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);
| | | | 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 |
|| 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<(int)parsePtr->numWords ; i++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, i);
}
TclEmitInstInt1( INST_TAILCALL, (int)parsePtr->numWords, envPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileThrowCmd --
|
| ︙ | ︙ | |||
2711 2712 2713 2714 2715 2716 2717 |
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
int numWords = parsePtr->numWords;
Tcl_Token *codeToken, *msgToken;
Tcl_Obj *objPtr;
| | > | 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 |
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
int numWords = parsePtr->numWords;
Tcl_Token *codeToken, *msgToken;
Tcl_Obj *objPtr;
int codeKnown, codeIsList, codeIsValid;
size_t len;
if (numWords != 3) {
return TCL_ERROR;
}
codeToken = TokenAfter(parsePtr->tokenPtr);
msgToken = TokenAfter(codeToken);
|
| ︙ | ︙ | |||
2735 2736 2737 2738 2739 2740 2741 |
if (!codeKnown) {
CompileWord(envPtr, codeToken, interp, 1);
PUSH( "-errorcode");
}
CompileWord(envPtr, msgToken, interp, 2);
codeIsList = codeKnown && (TCL_OK ==
| | | 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 |
if (!codeKnown) {
CompileWord(envPtr, codeToken, interp, 1);
PUSH( "-errorcode");
}
CompileWord(envPtr, msgToken, interp, 2);
codeIsList = codeKnown && (TCL_OK ==
TclListObjLengthM(interp, objPtr, &len));
codeIsValid = codeIsList && (len != 0);
if (codeIsValid) {
Tcl_Obj *errPtr, *dictPtr;
TclNewLiteralStringObj(errPtr, "-errorcode");
TclNewObj(dictPtr);
|
| ︙ | ︙ | |||
2852 2853 2854 2855 2856 2857 2858 |
memset(matchClauses, 0, sizeof(Tcl_Obj *) * numHandlers);
matchCodes = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);
resultVarIndices = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);
optionVarIndices = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);
for (i=0 ; i<numHandlers ; i++) {
Tcl_Obj *tmpObj, **objv;
| | | | 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 |
memset(matchClauses, 0, sizeof(Tcl_Obj *) * numHandlers);
matchCodes = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);
resultVarIndices = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);
optionVarIndices = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);
for (i=0 ; i<numHandlers ; i++) {
Tcl_Obj *tmpObj, **objv;
size_t objc;
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
goto failedToCompile;
}
if (tokenPtr[1].size == 4
&& !strncmp(tokenPtr[1].start, "trap", 4)) {
/*
* Parse the list of errorCode words to match against.
*/
matchCodes[i] = TCL_ERROR;
tokenPtr = TokenAfter(tokenPtr);
TclNewObj(tmpObj);
Tcl_IncrRefCount(tmpObj);
if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)
|| TclListObjLengthM(NULL, tmpObj, &objc) != TCL_OK
|| (objc == 0)) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
Tcl_ListObjReplace(NULL, tmpObj, 0, 0, 0, NULL);
matchClauses[i] = tmpObj;
} else if (tokenPtr[1].size == 2
|
| ︙ | ︙ | |||
2911 2912 2913 2914 2915 2916 2917 |
tokenPtr = TokenAfter(tokenPtr);
TclNewObj(tmpObj);
Tcl_IncrRefCount(tmpObj);
if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
| | | 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 |
tokenPtr = TokenAfter(tokenPtr);
TclNewObj(tmpObj);
Tcl_IncrRefCount(tmpObj);
if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
if (TclListObjGetElementsM(NULL, tmpObj, &objc, &objv) != TCL_OK
|| (objc > 2)) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
if (objc > 0) {
size_t len;
const char *varname = Tcl_GetStringFromObj(objv[0], &len);
|
| ︙ | ︙ | |||
3050 3051 3052 3053 3054 3055 3056 |
Tcl_Obj **matchClauses,
int *resultVars,
int *optionVars,
Tcl_Token **handlerTokens)
{
DefineLineInformation; /* TIP #280 */
int range, resultVar, optionsVar;
| | | | 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 |
Tcl_Obj **matchClauses,
int *resultVars,
int *optionVars,
Tcl_Token **handlerTokens)
{
DefineLineInformation; /* TIP #280 */
int range, resultVar, optionsVar;
int i, j, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0;
size_t slen, len;
int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
int *noError;
char buf[TCL_INTEGER_SPACE];
resultVar = AnonymousLocal(envPtr);
optionsVar = AnonymousLocal(envPtr);
if (resultVar < 0 || optionsVar < 0) {
|
| ︙ | ︙ | |||
3126 3127 3128 3129 3130 3131 3132 |
sprintf(buf, "%d", matchCodes[i]);
OP( DUP);
PushLiteral(envPtr, buf, strlen(buf));
OP( EQ);
JUMP4( JUMP_FALSE, notCodeJumpSource);
if (matchClauses[i]) {
const char *p;
| | | 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 |
sprintf(buf, "%d", matchCodes[i]);
OP( DUP);
PushLiteral(envPtr, buf, strlen(buf));
OP( EQ);
JUMP4( JUMP_FALSE, notCodeJumpSource);
if (matchClauses[i]) {
const char *p;
TclListObjLengthM(NULL, matchClauses[i], &len);
/*
* Match the errorcode according to try/trap rules.
*/
LOAD( optionsVar);
PUSH( "-errorcode");
|
| ︙ | ︙ | |||
3261 3262 3263 3264 3265 3266 3267 |
Tcl_Obj **matchClauses,
int *resultVars,
int *optionVars,
Tcl_Token **handlerTokens,
Tcl_Token *finallyToken) /* Not NULL */
{
DefineLineInformation; /* TIP #280 */
| | | | 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 |
Tcl_Obj **matchClauses,
int *resultVars,
int *optionVars,
Tcl_Token **handlerTokens,
Tcl_Token *finallyToken) /* Not NULL */
{
DefineLineInformation; /* TIP #280 */
int range, resultVar, optionsVar, i, j, forwardsNeedFixing = 0;
int trapZero = 0, afterBody = 0, finalOK, finalError, noFinalError;
int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
char buf[TCL_INTEGER_SPACE];
size_t slen, len;
resultVar = AnonymousLocal(envPtr);
optionsVar = AnonymousLocal(envPtr);
if (resultVar < 0 || optionsVar < 0) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
3338 3339 3340 3341 3342 3343 3344 |
sprintf(buf, "%d", matchCodes[i]);
OP( DUP);
PushLiteral(envPtr, buf, strlen(buf));
OP( EQ);
JUMP4( JUMP_FALSE, notCodeJumpSource);
if (matchClauses[i]) {
| | | 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 |
sprintf(buf, "%d", matchCodes[i]);
OP( DUP);
PushLiteral(envPtr, buf, strlen(buf));
OP( EQ);
JUMP4( JUMP_FALSE, notCodeJumpSource);
if (matchClauses[i]) {
TclListObjLengthM(NULL, matchClauses[i], &len);
/*
* Match the errorcode according to try/trap rules.
*/
LOAD( optionsVar);
PUSH( "-errorcode");
|
| ︙ | ︙ | |||
3636 3637 3638 3639 3640 3641 3642 |
/*
* 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]
*/
| | | 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 |
/*
* 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<(int)parsePtr->numWords ; i++) {
Tcl_Obj *leadingWord;
TclNewObj(leadingWord);
varTokenPtr = TokenAfter(varTokenPtr);
if (!TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) {
TclDecrRefCount(leadingWord);
|
| ︙ | ︙ | |||
3700 3701 3702 3703 3704 3705 3706 |
* Issue instructions to unset each of the named variables.
*/
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
for (i=0; i<haveFlags;i++) {
varTokenPtr = TokenAfter(varTokenPtr);
}
| | | 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 |
* Issue instructions to unset each of the named variables.
*/
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
for (i=0; i<haveFlags;i++) {
varTokenPtr = TokenAfter(varTokenPtr);
}
for (i=1+haveFlags ; i<(int)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.
*/
|
| ︙ | ︙ | |||
3985 3986 3987 3988 3989 3990 3991 |
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
int i;
| | | | 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 |
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
int i;
if ((int)parsePtr->numWords < 2) {
return TCL_ERROR;
}
OP( NS_CURRENT);
for (i = 1 ; i < (int)parsePtr->numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
OP4( LIST, i);
OP( YIELD_TO_INVOKE);
return TCL_OK;
}
|
| ︙ | ︙ | |||
4068 4069 4070 4071 4072 4073 4074 |
Tcl_Parse *parsePtr,
const char *identity,
int instruction,
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
| | | 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 |
Tcl_Parse *parsePtr,
const char *identity,
int instruction,
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
size_t words;
/* TODO: Consider support for compiling expanded args. */
for (words=1 ; words<parsePtr->numWords ; words++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, words);
}
if (parsePtr->numWords <= 2) {
|
| ︙ | ︙ | |||
4155 4156 4157 4158 4159 4160 4161 |
int instruction,
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
/* TODO: Consider support for compiling expanded args. */
| | | | 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 |
int instruction,
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
/* TODO: Consider support for compiling expanded args. */
if ((int)parsePtr->numWords < 3) {
PUSH("1");
} else if (parsePtr->numWords == 3) {
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
TclEmitOpcode(instruction, envPtr);
} else if (envPtr->procPtr == NULL) {
/*
* No local variable space!
*/
return TCL_ERROR;
} else {
int tmpIndex = AnonymousLocal(envPtr);
size_t words;
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
STORE(tmpIndex);
TclEmitOpcode(instruction, envPtr);
|
| ︙ | ︙ | |||
4307 4308 4309 4310 4311 4312 4313 |
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
| | | 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 |
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
size_t words;
/*
* This one has its own implementation because the ** operator is the only
* one with right associativity.
*/
for (words=1 ; words<parsePtr->numWords ; words++) {
|
| ︙ | ︙ | |||
4508 4509 4510 4511 4512 4513 4514 |
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
| | | 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 |
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
size_t words;
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords == 1) {
/*
* Fallback to direct eval to report syntax error.
*/
|
| ︙ | ︙ | |||
4553 4554 4555 4556 4557 4558 4559 |
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
| | | 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 |
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
size_t words;
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords == 1) {
/*
* Fallback to direct eval to report syntax error.
*/
|
| ︙ | ︙ |
Changes to generic/tclCompExpr.c.
| ︙ | ︙ | |||
1802 1803 1804 1805 1806 1807 1808 | * All the Tcl_Tokens allocated and filled belong to * this subexpression. The first token is the leading * TCL_TOKEN_SUB_EXPR token, and all the rest (one fewer) * are its components. */ subExprTokenPtr->numComponents = | | | 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 | * All the Tcl_Tokens allocated and filled belong to * this subexpression. The first token is the leading * TCL_TOKEN_SUB_EXPR token, and all the rest (one fewer) * are its components. */ subExprTokenPtr->numComponents = ((int)parsePtr->numTokens - subExprTokenIdx) - 1; /* * Finally, as we return up the tree to our parent, pop the * parent subexpression off our subexpression stack, and * fill in the zero numComponents for the operator Tcl_Token. */ |
| ︙ | ︙ | |||
2214 2215 2216 2217 2218 2219 2220 |
funcList, parsePtr, 0 /* parseOnly */);
if (code == TCL_OK) {
/*
* Valid parse; compile the tree.
*/
| | | | | 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 |
funcList, parsePtr, 0 /* parseOnly */);
if (code == TCL_OK) {
/*
* Valid parse; compile the tree.
*/
size_t objc;
Tcl_Obj *const *litObjv;
Tcl_Obj **funcObjv;
/* TIP #280 : Track Lines within the expression */
TclAdvanceLines(&envPtr->line, script,
script + TclParseAllWhiteSpace(script, numBytes));
TclListObjGetElementsM(NULL, litList, &objc, (Tcl_Obj ***)&litObjv);
TclListObjGetElementsM(NULL, funcList, &objc, &funcObjv);
CompileExprTree(interp, opTree, 0, &litObjv, funcObjv,
parsePtr->tokenPtr, envPtr, optimize);
} else {
TclCompileSyntaxError(interp, envPtr);
}
Tcl_FreeParse(parsePtr);
|
| ︙ | ︙ |
Changes to generic/tclCompile.c.
| ︙ | ︙ | |||
669 670 671 672 673 674 675 | static ByteCode * CompileSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); static void DupByteCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static unsigned char * EncodeCmdLocMap(CompileEnv *envPtr, ByteCode *codePtr, unsigned char *startPtr); static void EnterCmdExtentData(CompileEnv *envPtr, | | | | | | 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 | static ByteCode * CompileSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); static void DupByteCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static unsigned char * EncodeCmdLocMap(CompileEnv *envPtr, ByteCode *codePtr, unsigned char *startPtr); static void EnterCmdExtentData(CompileEnv *envPtr, size_t cmdNumber, size_t numSrcBytes, size_t numCodeBytes); static void EnterCmdStartData(CompileEnv *envPtr, size_t cmdNumber, size_t srcOffset, size_t codeOffset); static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); static int IsCompactibleCompileEnv(CompileEnv *envPtr); static void PreventCycle(Tcl_Obj *objPtr, CompileEnv *envPtr); #ifdef TCL_COMPILE_STATS static void RecordByteCodeStats(ByteCode *codePtr); #endif /* TCL_COMPILE_STATS */ static int SetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void StartExpanding(CompileEnv *envPtr); /* * TIP #280: Helper for building the per-word line information of all compiled * commands. */ static void EnterCmdWordData(ExtCmdLoc *eclPtr, size_t srcOffset, Tcl_Token *tokenPtr, const char *cmd, size_t numWords, size_t line, int *clNext, int **lines, CompileEnv *envPtr); static void ReleaseCmdWordData(ExtCmdLoc *eclPtr); /* * tclByteCodeType provides the standard type management procedures for the * bytecode type. */ |
| ︙ | ︙ | |||
758 759 760 761 762 763 764 |
int
TclSetByteCodeFromAny(
Tcl_Interp *interp, /* The interpreter for which the code is being
* compiled. Must not be NULL. */
Tcl_Obj *objPtr, /* The object to make a ByteCode object. */
CompileHookProc *hookProc, /* Procedure to invoke after compilation. */
| | | 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 |
int
TclSetByteCodeFromAny(
Tcl_Interp *interp, /* The interpreter for which the code is being
* compiled. Must not be NULL. */
Tcl_Obj *objPtr, /* The object to make a ByteCode object. */
CompileHookProc *hookProc, /* Procedure to invoke after compilation. */
void *clientData) /* Hook procedure private data. */
{
Interp *iPtr = (Interp *) interp;
CompileEnv compEnv; /* Compilation environment structure allocated
* in frame. */
size_t length;
int result = TCL_OK;
const char *stringPtr;
|
| ︙ | ︙ | |||
1032 1033 1034 1035 1036 1037 1038 | ByteCodeStats *statsPtr; Tcl_Time destroyTime; int lifetimeSec, lifetimeMicroSec, log2; statsPtr = &iPtr->stats; statsPtr->numByteCodesFreed++; | | | 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 | ByteCodeStats *statsPtr; Tcl_Time destroyTime; int lifetimeSec, lifetimeMicroSec, log2; statsPtr = &iPtr->stats; statsPtr->numByteCodesFreed++; statsPtr->currentSrcBytes -= (double)codePtr->numSrcBytes; statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize; statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes; statsPtr->currentLitBytes -= (double) codePtr->numLitObjects * sizeof(Tcl_Obj *); statsPtr->currentExceptBytes -= (double) codePtr->numExceptRanges * sizeof(ExceptionRange); |
| ︙ | ︙ | |||
1378 1379 1380 1381 1382 1383 1384 |
TclReleaseByteCode(codePtr);
}
static void
ReleaseCmdWordData(
ExtCmdLoc *eclPtr)
{
| | | 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 |
TclReleaseByteCode(codePtr);
}
static void
ReleaseCmdWordData(
ExtCmdLoc *eclPtr)
{
size_t i;
if (eclPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(eclPtr->path);
}
for (i=0 ; i<eclPtr->nuloc ; i++) {
Tcl_Free(eclPtr->loc[i].line);
}
|
| ︙ | ︙ | |||
1540 1541 1542 1543 1544 1545 1546 | * ctx.data.tebc.codePtr is used instead. */ TclGetSrcInfoForPc(ctxPtr); pc = 1; } | | | 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 |
* ctx.data.tebc.codePtr is used instead.
*/
TclGetSrcInfoForPc(ctxPtr);
pc = 1;
}
if ((ctxPtr->nline <= (size_t)word) || (ctxPtr->line[word] < 0)) {
/*
* Word is not a literal, relative counting.
*/
envPtr->line = 1;
envPtr->extCmdMapPtr->type =
(envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC);
|
| ︙ | ︙ | |||
1634 1635 1636 1637 1638 1639 1640 |
}
if (envPtr->iPtr) {
/*
* We never converted to Bytecode, so free the things we would
* have transferred to it.
*/
| | | 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 |
}
if (envPtr->iPtr) {
/*
* We never converted to Bytecode, so free the things we would
* have transferred to it.
*/
size_t i;
LiteralEntry *entryPtr = envPtr->literalArrayPtr;
AuxData *auxDataPtr = envPtr->auxDataArrayPtr;
for (i = 0; i < envPtr->literalArrayNext; i++) {
TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, entryPtr->objPtr);
entryPtr++;
}
|
| ︙ | ︙ | |||
2022 2023 2024 2025 2026 2027 2028 |
int *wlines, wlineat;
int cmdLine = envPtr->line;
int *clNext = envPtr->clNext;
int cmdIdx = envPtr->numCommands;
int startCodeOffset = envPtr->codeNext - envPtr->codeStart;
int depth = TclGetStackDepth(envPtr);
| | | 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 |
int *wlines, wlineat;
int cmdLine = envPtr->line;
int *clNext = envPtr->clNext;
int cmdIdx = envPtr->numCommands;
int startCodeOffset = envPtr->codeNext - envPtr->codeStart;
int depth = TclGetStackDepth(envPtr);
assert ((int)parsePtr->numWords > 0);
/* Pre-Compile */
TclNewObj(cmdObj);
envPtr->numCommands++;
EnterCmdStartData(envPtr, cmdIdx,
parsePtr->commandStart - envPtr->source, startCodeOffset);
|
| ︙ | ︙ | |||
2067 2068 2069 2070 2071 2072 2073 |
if ((cmdPtr->compileProc == NULL)
|| (cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION)
|| (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
cmdPtr = NULL;
}
}
if (cmdPtr && !(cmdPtr->flags & CMD_COMPILES_EXPANDED)) {
| | | | | | 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 |
if ((cmdPtr->compileProc == NULL)
|| (cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION)
|| (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
cmdPtr = NULL;
}
}
if (cmdPtr && !(cmdPtr->flags & CMD_COMPILES_EXPANDED)) {
expand = ExpandRequested(parsePtr->tokenPtr, (int)parsePtr->numWords);
if (expand) {
/* We need to expand, but compileProc cannot. */
cmdPtr = NULL;
}
}
}
/* If cmdPtr != NULL, try to call cmdPtr->compileProc */
if (cmdPtr) {
code = CompileCmdCompileProc(interp, parsePtr, cmdPtr, envPtr);
}
if (code == TCL_ERROR) {
if (expand < 0) {
expand = ExpandRequested(parsePtr->tokenPtr, (int)parsePtr->numWords);
}
if (expand) {
CompileExpanded(interp, parsePtr->tokenPtr,
cmdKnown ? cmdObj : NULL, (int)parsePtr->numWords, envPtr);
} else {
TclCompileInvocation(interp, parsePtr->tokenPtr,
cmdKnown ? cmdObj : NULL, (int)parsePtr->numWords, envPtr);
}
}
Tcl_DecrRefCount(cmdObj);
TclEmitOpcode(INST_POP, envPtr);
EnterCmdExtentData(envPtr, cmdIdx,
|
| ︙ | ︙ | |||
2225 2226 2227 2228 2229 2230 2231 | * either the end of script, or a command-terminating semi-colon. * In either case, the TclAdvance*() calls have nothing to do. * Finally, when no words are parsed, no tokens have been * allocated at parsePtr->tokenPtr so there's also nothing for * Tcl_FreeParse() to do. * * The advantage of this shortcut is that CompileCommandTokens() | | | 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 | * either the end of script, or a command-terminating semi-colon. * In either case, the TclAdvance*() calls have nothing to do. * Finally, when no words are parsed, no tokens have been * allocated at parsePtr->tokenPtr so there's also nothing for * Tcl_FreeParse() to do. * * The advantage of this shortcut is that CompileCommandTokens() * can be written with an assumption that (int)parsePtr->numWords > 0, with * the implication the CCT() always generates bytecode. */ continue; } /* * Avoid stack exhaustion by too many nested calls of TclCompileScript |
| ︙ | ︙ | |||
2311 2312 2313 2314 2315 2316 2317 |
TclCompileVarSubst(
Tcl_Interp *interp,
Tcl_Token *tokenPtr,
CompileEnv *envPtr)
{
const char *p, *name = tokenPtr[1].start;
size_t i, nameBytes = tokenPtr[1].size;
| > | | 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 |
TclCompileVarSubst(
Tcl_Interp *interp,
Tcl_Token *tokenPtr,
CompileEnv *envPtr)
{
const char *p, *name = tokenPtr[1].start;
size_t i, nameBytes = tokenPtr[1].size;
size_t localVar;
int localVarName = 1;
/*
* Determine how the variable name should be handled: if it contains any
* namespace qualifiers it is not a local variable (localVarName=-1); if
* it looks like an array element and the token has a single component, it
* should not be created here [Bug 569438] (localVarName=0); otherwise,
* the local variable can safely be created (localVarName=1).
|
| ︙ | ︙ | |||
2338 2339 2340 2341 2342 2343 2344 |
}
/*
* Either push the variable's name, or find its index in the array
* of local variables in a procedure frame.
*/
| | | | | | > | 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 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 2405 2406 2407 |
}
/*
* Either push the variable's name, or find its index in the array
* of local variables in a procedure frame.
*/
localVar = TCL_INDEX_NONE;
if (localVarName != -1) {
localVar = TclFindCompiledLocal(name, nameBytes, localVarName, envPtr);
}
if (localVar == TCL_INDEX_NONE) {
PushLiteral(envPtr, name, nameBytes);
}
/*
* Emit instructions to load the variable.
*/
TclAdvanceLines(&envPtr->line, tokenPtr[1].start,
tokenPtr[1].start + tokenPtr[1].size);
if (tokenPtr->numComponents == 1) {
if (localVar == TCL_INDEX_NONE) {
TclEmitOpcode(INST_LOAD_STK, envPtr);
} else if (localVar <= 255) {
TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr);
} else {
TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, envPtr);
}
} else {
TclCompileTokens(interp, tokenPtr+2, tokenPtr->numComponents-1, envPtr);
if (localVar == TCL_INDEX_NONE) {
TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
} else if (localVar <= 255) {
TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, envPtr);
} else {
TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr);
}
}
}
void
TclCompileTokens(
Tcl_Interp *interp, /* Used for error and status reporting. */
Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to
* compile. */
size_t count1, /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
Tcl_DString textBuffer; /* Holds concatenated chars from adjacent
* TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
char buffer[4] = "";
int i, numObjsToConcat, adjust;
size_t length;
unsigned char *entryCodeNext = envPtr->codeNext;
#define NUM_STATIC_POS 20
int isLiteral, maxNumCL, numCL;
int *clPosition = NULL;
int depth = TclGetStackDepth(envPtr);
int count = count1;
/*
* if this is actually a literal, handle continuation lines by
* preallocating a small table to store the locations of any continuation
* lines we find in this literal. The table is extended if needed.
*
* Note: In contrast with the analagous code in 'TclSubstTokens()' the
|
| ︙ | ︙ | |||
2595 2596 2597 2598 2599 2600 2601 |
*/
void
TclCompileCmdWord(
Tcl_Interp *interp, /* Used for error and status reporting. */
Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens for
* a command word to compile inline. */
| | > > | 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 |
*/
void
TclCompileCmdWord(
Tcl_Interp *interp, /* Used for error and status reporting. */
Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens for
* a command word to compile inline. */
size_t count1, /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
int count = count1;
if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) {
/*
* The common case that there is a single text token. Compile it
* into an inline sequence of instructions.
*/
TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr);
|
| ︙ | ︙ | |||
2644 2645 2646 2647 2648 2649 2650 |
void
TclCompileExprWords(
Tcl_Interp *interp, /* Used for error and status reporting. */
Tcl_Token *tokenPtr, /* Points to first in an array of word tokens
* tokens for the expression to compile
* inline. */
| | > | 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 |
void
TclCompileExprWords(
Tcl_Interp *interp, /* Used for error and status reporting. */
Tcl_Token *tokenPtr, /* Points to first in an array of word tokens
* tokens for the expression to compile
* inline. */
size_t numWords1, /* Number of word tokens starting at tokenPtr.
* Must be at least 1. Each word token
* contains one or more subtokens. */
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
Tcl_Token *wordPtr;
int i, concatItems;
int numWords = numWords1;
/*
* If the expression is a single word that doesn't require substitutions,
* just compile its string into inline instructions.
*/
if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
|
| ︙ | ︙ | |||
2716 2717 2718 2719 2720 2721 2722 |
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
int i;
tokenPtr = parsePtr->tokenPtr;
| | | 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 |
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
int i;
tokenPtr = parsePtr->tokenPtr;
for (i = 1; i < (int)parsePtr->numWords; i++) {
tokenPtr = tokenPtr + tokenPtr->numComponents + 1;
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
CompileTokens(envPtr, tokenPtr, interp);
TclEmitOpcode(INST_POP, envPtr);
}
}
|
| ︙ | ︙ | |||
2758 2759 2760 2761 2762 2763 2764 |
*/
static void
PreventCycle(
Tcl_Obj *objPtr,
CompileEnv *envPtr)
{
| | | 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 |
*/
static void
PreventCycle(
Tcl_Obj *objPtr,
CompileEnv *envPtr)
{
size_t i;
for (i = 0; i < envPtr->literalArrayNext; i++) {
if (objPtr == TclFetchLiteral(envPtr, i)) {
/*
* Prevent circular reference where the bytecode internalrep of
* a value contains a literal which is that same value.
* If this is allowed to happen, refcount decrements may not
|
| ︙ | ︙ | |||
2816 2817 2818 2819 2820 2821 2822 2823 2824 |
objArrayBytes = envPtr->literalArrayNext * sizeof(Tcl_Obj *);
exceptArrayBytes = envPtr->exceptArrayNext * sizeof(ExceptionRange);
auxDataArrayBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
cmdLocBytes = GetCmdLocEncodingSize(envPtr);
/*
* Compute the total number of bytes needed for this bytecode.
*/
| > > > > | | 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 |
objArrayBytes = envPtr->literalArrayNext * sizeof(Tcl_Obj *);
exceptArrayBytes = envPtr->exceptArrayNext * sizeof(ExceptionRange);
auxDataArrayBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
cmdLocBytes = GetCmdLocEncodingSize(envPtr);
/*
* Compute the total number of bytes needed for this bytecode.
*
* Note that code bytes need not be aligned but since later elements are we
* need to pad anyway, either directly after ByteCode or after codeBytes,
* and it's easier and more consistent to do the former.
*/
structureSize = TCL_ALIGN(sizeof(ByteCode)); /* align code bytes */
structureSize += TCL_ALIGN(codeBytes); /* align object array */
structureSize += TCL_ALIGN(objArrayBytes); /* align exc range arr */
structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
structureSize += auxDataArrayBytes;
structureSize += cmdLocBytes;
if (envPtr->iPtr->varFramePtr != NULL) {
|
| ︙ | ︙ | |||
2857 2858 2859 2860 2861 2862 2863 |
codePtr->numLitObjects = numLitObjects;
codePtr->numExceptRanges = envPtr->exceptArrayNext;
codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
codePtr->numCmdLocBytes = cmdLocBytes;
codePtr->maxExceptDepth = envPtr->maxExceptDepth;
codePtr->maxStackDepth = envPtr->maxStackDepth;
| | | 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 |
codePtr->numLitObjects = numLitObjects;
codePtr->numExceptRanges = envPtr->exceptArrayNext;
codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
codePtr->numCmdLocBytes = cmdLocBytes;
codePtr->maxExceptDepth = envPtr->maxExceptDepth;
codePtr->maxStackDepth = envPtr->maxStackDepth;
p += TCL_ALIGN(sizeof(ByteCode)); /* align code bytes */
codePtr->codeStart = p;
memcpy(p, envPtr->codeStart, codeBytes);
p += TCL_ALIGN(codeBytes); /* align object array */
codePtr->objArrayPtr = (Tcl_Obj **) p;
for (i = 0; i < numLitObjects; i++) {
codePtr->objArrayPtr[i] = TclFetchLiteral(envPtr, i);
|
| ︙ | ︙ | |||
2971 2972 2973 2974 2975 2976 2977 | * Side effects: * Creates and registers a new local variable if create is 1 and the * variable is unknown, or if the name is NULL. * *---------------------------------------------------------------------- */ | | | | | 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 |
* Side effects:
* Creates and registers a new local variable if create is 1 and the
* variable is unknown, or if the name is NULL.
*
*----------------------------------------------------------------------
*/
size_t
TclFindCompiledLocal(
const char *name, /* Points to first character of the name of a
* scalar or array variable. If NULL, a
* temporary var should be created. */
size_t nameBytes, /* Number of bytes in the name. */
int create, /* If 1, allocate a local frame entry for the
* variable if it is new. */
CompileEnv *envPtr) /* Points to the current compile environment*/
{
CompiledLocal *localPtr;
size_t localVar = TCL_INDEX_NONE;
size_t i;
Proc *procPtr;
/*
* If not creating a temporary, does a local variable of the specified
* name already exist?
*/
|
| ︙ | ︙ | |||
3005 3006 3007 3008 3009 3010 3011 |
LocalCache *cachePtr = envPtr->iPtr->varFramePtr->localCachePtr;
const char *localName;
Tcl_Obj **varNamePtr;
size_t len;
if (!cachePtr || !name) {
| | | | | 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 |
LocalCache *cachePtr = envPtr->iPtr->varFramePtr->localCachePtr;
const char *localName;
Tcl_Obj **varNamePtr;
size_t len;
if (!cachePtr || !name) {
return TCL_INDEX_NONE;
}
varNamePtr = &cachePtr->varName0;
for (i=0; i < cachePtr->numVars; varNamePtr++, i++) {
if (*varNamePtr) {
localName = Tcl_GetStringFromObj(*varNamePtr, &len);
if ((len == nameBytes) && !strncmp(name, localName, len)) {
return i;
}
}
}
return TCL_INDEX_NONE;
}
if (name != NULL) {
size_t localCt = procPtr->numCompiledLocals;
localPtr = procPtr->firstLocalPtr;
for (i = 0; i < localCt; i++) {
if (!TclIsVarTemporary(localPtr)) {
char *localName = localPtr->name;
if ((nameBytes == localPtr->nameLength) &&
|
| ︙ | ︙ | |||
3149 3150 3151 3152 3153 3154 3155 |
*/
static void
EnterCmdStartData(
CompileEnv *envPtr, /* Points to the compilation environment
* structure in which to enter command
* location information. */
| | | | | | | 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 |
*/
static void
EnterCmdStartData(
CompileEnv *envPtr, /* Points to the compilation environment
* structure in which to enter command
* location information. */
size_t cmdIndex, /* Index of the command whose start data is
* being set. */
size_t srcOffset, /* Offset of first char of the command. */
size_t codeOffset) /* Offset of first byte of command code. */
{
CmdLocation *cmdLocPtr;
if (cmdIndex >= envPtr->numCommands) {
Tcl_Panic("EnterCmdStartData: bad command index %" TCL_Z_MODIFIER "u", cmdIndex);
}
if (cmdIndex >= envPtr->cmdMapEnd) {
/*
* Expand the command location array by allocating more storage from
* the heap. The currently allocated CmdLocation entries are stored
* from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive).
|
| ︙ | ︙ | |||
3198 3199 3200 3201 3202 3203 3204 |
Tcl_Panic("EnterCmdStartData: cmd map not sorted by code offset");
}
}
cmdLocPtr = &envPtr->cmdMapPtr[cmdIndex];
cmdLocPtr->codeOffset = codeOffset;
cmdLocPtr->srcOffset = srcOffset;
| | | | 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 |
Tcl_Panic("EnterCmdStartData: cmd map not sorted by code offset");
}
}
cmdLocPtr = &envPtr->cmdMapPtr[cmdIndex];
cmdLocPtr->codeOffset = codeOffset;
cmdLocPtr->srcOffset = srcOffset;
cmdLocPtr->numSrcBytes = TCL_INDEX_NONE;
cmdLocPtr->numCodeBytes = TCL_INDEX_NONE;
}
/*
*----------------------------------------------------------------------
*
* EnterCmdExtentData --
*
|
| ︙ | ︙ | |||
3228 3229 3230 3231 3232 3233 3234 |
*/
static void
EnterCmdExtentData(
CompileEnv *envPtr, /* Points to the compilation environment
* structure in which to enter command
* location information. */
| | | | | | | | 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 |
*/
static void
EnterCmdExtentData(
CompileEnv *envPtr, /* Points to the compilation environment
* structure in which to enter command
* location information. */
size_t cmdIndex, /* Index of the command whose source and code
* length data is being set. */
size_t numSrcBytes, /* Number of command source chars. */
size_t numCodeBytes) /* Offset of last byte of command code. */
{
CmdLocation *cmdLocPtr;
if (cmdIndex >= envPtr->numCommands) {
Tcl_Panic("EnterCmdExtentData: bad command index %" TCL_Z_MODIFIER "u", cmdIndex);
}
if (cmdIndex > envPtr->cmdMapEnd) {
Tcl_Panic("EnterCmdExtentData: missing start data for command %" TCL_Z_MODIFIER "u",
cmdIndex);
}
cmdLocPtr = &envPtr->cmdMapPtr[cmdIndex];
cmdLocPtr->numSrcBytes = numSrcBytes;
cmdLocPtr->numCodeBytes = numCodeBytes;
}
|
| ︙ | ︙ | |||
3274 3275 3276 3277 3278 3279 3280 |
*/
static void
EnterCmdWordData(
ExtCmdLoc *eclPtr, /* Points to the map environment structure in
* which to enter command location
* information. */
| | | | > | | 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 |
*/
static void
EnterCmdWordData(
ExtCmdLoc *eclPtr, /* Points to the map environment structure in
* which to enter command location
* information. */
size_t srcOffset, /* Offset of first char of the command. */
Tcl_Token *tokenPtr,
const char *cmd,
size_t numWords,
size_t line,
int *clNext,
int **wlines,
CompileEnv *envPtr)
{
ECL *ePtr;
const char *last;
size_t wordIdx, wordLine;
int *wwlines, *wordNext;
if (eclPtr->nuloc >= eclPtr->nloc) {
/*
* Expand the ECL array by allocating more storage from the heap. The
* currently allocated ECL entries are stored from eclPtr->loc[0] up
* to eclPtr->loc[eclPtr->nuloc-1] (inclusive).
*/
|
| ︙ | ︙ | |||
3320 3321 3322 3323 3324 3325 3326 |
wordIdx++, tokenPtr += tokenPtr->numComponents + 1) {
TclAdvanceLines(&wordLine, last, tokenPtr->start);
TclAdvanceContinuations(&wordLine, &wordNext,
tokenPtr->start - envPtr->source);
/* See Ticket 4b61afd660 */
wwlines[wordIdx] =
((wordIdx == 0) || TclWordKnownAtCompileTime(tokenPtr, NULL))
| | | 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 |
wordIdx++, tokenPtr += tokenPtr->numComponents + 1) {
TclAdvanceLines(&wordLine, last, tokenPtr->start);
TclAdvanceContinuations(&wordLine, &wordNext,
tokenPtr->start - envPtr->source);
/* See Ticket 4b61afd660 */
wwlines[wordIdx] =
((wordIdx == 0) || TclWordKnownAtCompileTime(tokenPtr, NULL))
? (int)wordLine : -1;
ePtr->line[wordIdx] = wordLine;
ePtr->next[wordIdx] = wordNext;
last = tokenPtr->start;
}
*wlines = wwlines;
eclPtr->nuloc ++;
|
| ︙ | ︙ | |||
3350 3351 3352 3353 3354 3355 3356 | * the array in expanded: a new array of double the size is allocated, if * envPtr->mallocedExceptArray is non-zero the old array is freed, and * ExceptionRange entries are copied from the old array to the new one. * *---------------------------------------------------------------------- */ | | | | | 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 |
* the array in expanded: a new array of double the size is allocated, if
* envPtr->mallocedExceptArray is non-zero the old array is freed, and
* ExceptionRange entries are copied from the old array to the new one.
*
*----------------------------------------------------------------------
*/
size_t
TclCreateExceptRange(
ExceptionRangeType type, /* The kind of ExceptionRange desired. */
CompileEnv *envPtr)/* Points to CompileEnv for which to create a
* new ExceptionRange structure. */
{
ExceptionRange *rangePtr;
ExceptionAux *auxPtr;
size_t index = envPtr->exceptArrayNext;
if (index >= envPtr->exceptArrayEnd) {
/*
* Expand the ExceptionRange array. The currently allocated entries
* are stored between elements 0 and (envPtr->exceptArrayNext - 1)
* [inclusive].
*/
size_t currBytes =
envPtr->exceptArrayNext * sizeof(ExceptionRange);
size_t currBytes2 = envPtr->exceptArrayNext * sizeof(ExceptionAux);
size_t newElems = 2*envPtr->exceptArrayEnd;
size_t newBytes = newElems * sizeof(ExceptionRange);
size_t newBytes2 = newElems * sizeof(ExceptionAux);
if (envPtr->mallocedExceptArray) {
envPtr->exceptArrayPtr =
(ExceptionRange *)Tcl_Realloc(envPtr->exceptArrayPtr, newBytes);
envPtr->exceptAuxArrayPtr =
|
| ︙ | ︙ | |||
3401 3402 3403 3404 3405 3406 3407 |
envPtr->exceptArrayEnd = newElems;
}
envPtr->exceptArrayNext++;
rangePtr = &envPtr->exceptArrayPtr[index];
rangePtr->type = type;
rangePtr->nestingLevel = envPtr->exceptDepth;
| | | | | | | | 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 |
envPtr->exceptArrayEnd = newElems;
}
envPtr->exceptArrayNext++;
rangePtr = &envPtr->exceptArrayPtr[index];
rangePtr->type = type;
rangePtr->nestingLevel = envPtr->exceptDepth;
rangePtr->codeOffset = TCL_INDEX_NONE;
rangePtr->numCodeBytes = TCL_INDEX_NONE;
rangePtr->breakOffset = TCL_INDEX_NONE;
rangePtr->continueOffset = TCL_INDEX_NONE;
rangePtr->catchOffset = TCL_INDEX_NONE;
auxPtr = &envPtr->exceptAuxArrayPtr[index];
auxPtr->supportsContinue = 1;
auxPtr->stackDepth = envPtr->currStackDepth;
auxPtr->expandTarget = envPtr->expandCount;
auxPtr->expandTargetDepth = TCL_INDEX_NONE;
auxPtr->numBreakTargets = 0;
auxPtr->breakTargets = NULL;
auxPtr->allocBreakTargets = 0;
auxPtr->numContinueTargets = 0;
auxPtr->continueTargets = NULL;
auxPtr->allocContinueTargets = 0;
return index;
|
| ︙ | ︙ | |||
3440 3441 3442 3443 3444 3445 3446 |
ExceptionRange *
TclGetInnermostExceptionRange(
CompileEnv *envPtr,
int returnCode,
ExceptionAux **auxPtrPtr)
{
| | | | | | 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 |
ExceptionRange *
TclGetInnermostExceptionRange(
CompileEnv *envPtr,
int returnCode,
ExceptionAux **auxPtrPtr)
{
size_t i = envPtr->exceptArrayNext;
ExceptionRange *rangePtr = envPtr->exceptArrayPtr + i;
while (i > 0) {
rangePtr--; i--;
if (CurrentOffset(envPtr) >= (int)rangePtr->codeOffset &&
(rangePtr->numCodeBytes == TCL_INDEX_NONE || CurrentOffset(envPtr) <
(int)rangePtr->codeOffset+(int)rangePtr->numCodeBytes) &&
(returnCode != TCL_CONTINUE ||
envPtr->exceptAuxArrayPtr[i].supportsContinue)) {
if (auxPtrPtr) {
*auxPtrPtr = envPtr->exceptAuxArrayPtr + i;
}
return rangePtr;
|
| ︙ | ︙ | |||
3489 3490 3491 3492 3493 3494 3495 |
Tcl_Panic("trying to add 'break' fixup to full exception range");
}
if (++auxPtr->numBreakTargets > auxPtr->allocBreakTargets) {
auxPtr->allocBreakTargets *= 2;
auxPtr->allocBreakTargets += 2;
if (auxPtr->breakTargets) {
| | | | | 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 |
Tcl_Panic("trying to add 'break' fixup to full exception range");
}
if (++auxPtr->numBreakTargets > auxPtr->allocBreakTargets) {
auxPtr->allocBreakTargets *= 2;
auxPtr->allocBreakTargets += 2;
if (auxPtr->breakTargets) {
auxPtr->breakTargets = (size_t *)Tcl_Realloc(auxPtr->breakTargets,
sizeof(size_t) * auxPtr->allocBreakTargets);
} else {
auxPtr->breakTargets =
(size_t *)Tcl_Alloc(sizeof(size_t) * auxPtr->allocBreakTargets);
}
}
auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr);
TclEmitInstInt4(INST_JUMP4, 0, envPtr);
}
void
|
| ︙ | ︙ | |||
3515 3516 3517 3518 3519 3520 3521 |
Tcl_Panic("trying to add 'continue' fixup to full exception range");
}
if (++auxPtr->numContinueTargets > auxPtr->allocContinueTargets) {
auxPtr->allocContinueTargets *= 2;
auxPtr->allocContinueTargets += 2;
if (auxPtr->continueTargets) {
| | | | | 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 |
Tcl_Panic("trying to add 'continue' fixup to full exception range");
}
if (++auxPtr->numContinueTargets > auxPtr->allocContinueTargets) {
auxPtr->allocContinueTargets *= 2;
auxPtr->allocContinueTargets += 2;
if (auxPtr->continueTargets) {
auxPtr->continueTargets = (size_t *)Tcl_Realloc(auxPtr->continueTargets,
sizeof(size_t) * auxPtr->allocContinueTargets);
} else {
auxPtr->continueTargets =
(size_t *)Tcl_Alloc(sizeof(size_t) * auxPtr->allocContinueTargets);
}
}
auxPtr->continueTargets[auxPtr->numContinueTargets - 1] =
CurrentOffset(envPtr);
TclEmitInstInt4(INST_JUMP4, 0, envPtr);
}
|
| ︙ | ︙ | |||
3544 3545 3546 3547 3548 3549 3550 |
*/
void
TclCleanupStackForBreakContinue(
CompileEnv *envPtr,
ExceptionAux *auxPtr)
{
| | | | 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 |
*/
void
TclCleanupStackForBreakContinue(
CompileEnv *envPtr,
ExceptionAux *auxPtr)
{
size_t savedStackDepth = envPtr->currStackDepth;
int toPop = envPtr->expandCount - auxPtr->expandTarget;
if (toPop > 0) {
while (toPop --> 0) {
TclEmitOpcode(INST_EXPAND_DROP, envPtr);
}
TclAdjustStackDepth((int)(auxPtr->expandTargetDepth - envPtr->currStackDepth),
envPtr);
envPtr->currStackDepth = auxPtr->expandTargetDepth;
}
toPop = envPtr->currStackDepth - auxPtr->stackDepth;
while (toPop --> 0) {
TclEmitOpcode(INST_POP, envPtr);
}
|
| ︙ | ︙ | |||
3587 3588 3589 3590 3591 3592 3593 |
TclEmitOpcode(INST_EXPAND_START, envPtr);
/*
* Update inner exception ranges with information about the environment
* where this expansion started.
*/
| | | | | 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 |
TclEmitOpcode(INST_EXPAND_START, envPtr);
/*
* Update inner exception ranges with information about the environment
* where this expansion started.
*/
for (i=0 ; i<(int)envPtr->exceptArrayNext ; i++) {
ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i];
ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[i];
/*
* Ignore loops unless they're still being built.
*/
if ((int)rangePtr->codeOffset > CurrentOffset(envPtr)) {
continue;
}
if (rangePtr->numCodeBytes != TCL_INDEX_NONE) {
continue;
}
/*
* Adequate condition: loops further out and exceptions further in
* don't actually need this information.
*/
|
| ︙ | ︙ | |||
3651 3652 3653 3654 3655 3656 3657 |
}
/*
* Do the jump fixups. Note that these are always issued as INST_JUMP4 so
* there is no need to fuss around with updating code offsets.
*/
| | | | | 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 |
}
/*
* Do the jump fixups. Note that these are always issued as INST_JUMP4 so
* there is no need to fuss around with updating code offsets.
*/
for (i=0 ; i<(int)auxPtr->numBreakTargets ; i++) {
site = envPtr->codeStart + auxPtr->breakTargets[i];
offset = rangePtr->breakOffset - auxPtr->breakTargets[i];
TclUpdateInstInt4AtPc(INST_JUMP4, offset, site);
}
for (i=0 ; i<(int)auxPtr->numContinueTargets ; i++) {
site = envPtr->codeStart + auxPtr->continueTargets[i];
if (rangePtr->continueOffset == TCL_INDEX_NONE) {
int j;
/*
* WTF? Can't bind, so revert to an INST_CONTINUE. Not enough
* space to do anything else.
*/
|
| ︙ | ︙ | |||
3711 3712 3713 3714 3715 3716 3717 | * * Side effects: * If there is not enough room in the CompileEnv's AuxData array, its size * is doubled. *---------------------------------------------------------------------- */ | | | | | | 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 |
*
* Side effects:
* If there is not enough room in the CompileEnv's AuxData array, its size
* is doubled.
*----------------------------------------------------------------------
*/
size_t
TclCreateAuxData(
void *clientData, /* The compilation auxiliary data to store in
* the new aux data record. */
const AuxDataType *typePtr, /* Pointer to the type to attach to this
* AuxData */
CompileEnv *envPtr)/* Points to the CompileEnv for which a new
* aux data structure is to be allocated. */
{
size_t index; /* Index for the new AuxData structure. */
AuxData *auxDataPtr;
/* Points to the new AuxData structure */
index = envPtr->auxDataArrayNext;
if (index >= envPtr->auxDataArrayEnd) {
/*
* Expand the AuxData array. The currently allocated entries are
* stored between elements 0 and (envPtr->auxDataArrayNext - 1)
* [inclusive].
*/
size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
size_t newElems = 2*envPtr->auxDataArrayEnd;
size_t newBytes = newElems * sizeof(AuxData);
if (envPtr->mallocedAuxDataArray) {
envPtr->auxDataArrayPtr =
(AuxData *)Tcl_Realloc(envPtr->auxDataArrayPtr, newBytes);
} else {
/*
|
| ︙ | ︙ | |||
3822 3823 3824 3825 3826 3827 3828 |
/*
* The currently allocated jump fixup entries are stored from fixup[0] up
* to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume
* fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd.
*/
size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);
| | | 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 |
/*
* The currently allocated jump fixup entries are stored from fixup[0] up
* to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume
* fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd.
*/
size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);
size_t newElems = 2*(fixupArrayPtr->end + 1);
size_t newBytes = newElems * sizeof(JumpFixup);
if (fixupArrayPtr->mallocedArray) {
fixupArrayPtr->fixup = (JumpFixup *)Tcl_Realloc(fixupArrayPtr->fixup, newBytes);
} else {
/*
* fixupArrayPtr->fixup isn't a Tcl_Alloc'd pointer, so we must code a
|
| ︙ | ︙ | |||
4036 4037 4038 4039 4040 4041 4042 |
for (k = firstRange; k <= lastRange; k++) {
ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[k];
rangePtr->codeOffset += 3;
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
rangePtr->breakOffset += 3;
| | | | | | 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 |
for (k = firstRange; k <= lastRange; k++) {
ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[k];
rangePtr->codeOffset += 3;
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
rangePtr->breakOffset += 3;
if (rangePtr->continueOffset != TCL_INDEX_NONE) {
rangePtr->continueOffset += 3;
}
break;
case CATCH_EXCEPTION_RANGE:
rangePtr->catchOffset += 3;
break;
default:
Tcl_Panic("TclFixupForwardJump: bad ExceptionRange type %d",
rangePtr->type);
}
}
for (k = 0 ; k < (int)envPtr->exceptArrayNext ; k++) {
ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[k];
int i;
for (i=0 ; i<(int)auxPtr->numBreakTargets ; i++) {
if (jumpFixupPtr->codeOffset < auxPtr->breakTargets[i]) {
auxPtr->breakTargets[i] += 3;
}
}
for (i=0 ; i<(int)auxPtr->numContinueTargets ; i++) {
if (jumpFixupPtr->codeOffset < auxPtr->continueTargets[i]) {
auxPtr->continueTargets[i] += 3;
}
}
}
return 1; /* the jump was grown */
|
| ︙ | ︙ | |||
4153 4154 4155 4156 4157 4158 4159 |
*/
rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE,
&auxContinuePtr);
if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) {
auxContinuePtr = NULL;
} else if (auxContinuePtr->stackDepth == envPtr->currStackDepth-wordCount
| | | | | 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 |
*/
rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE,
&auxContinuePtr);
if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) {
auxContinuePtr = NULL;
} else if (auxContinuePtr->stackDepth == envPtr->currStackDepth-wordCount
&& (auxContinuePtr->expandTarget+expandCount == envPtr->expandCount)) {
auxContinuePtr = NULL;
} else {
continueRange = auxContinuePtr - envPtr->exceptAuxArrayPtr;
}
rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxBreakPtr);
if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) {
auxBreakPtr = NULL;
} else if (auxContinuePtr == NULL
&& auxBreakPtr->stackDepth+wordCount == envPtr->currStackDepth
&& auxBreakPtr->expandTarget+expandCount == envPtr->expandCount) {
auxBreakPtr = NULL;
} else {
breakRange = auxBreakPtr - envPtr->exceptAuxArrayPtr;
}
if (auxBreakPtr != NULL || auxContinuePtr != NULL) {
loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
|
| ︙ | ︙ | |||
4210 4211 4212 4213 4214 4215 4216 |
/*
* If we're generating a special wrapper exception range, we need to
* finish that up now.
*/
if (auxBreakPtr != NULL || auxContinuePtr != NULL) {
| | | | 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 |
/*
* If we're generating a special wrapper exception range, we need to
* finish that up now.
*/
if (auxBreakPtr != NULL || auxContinuePtr != NULL) {
size_t savedStackDepth = envPtr->currStackDepth;
size_t savedExpandCount = envPtr->expandCount;
JumpFixup nonTrapFixup;
if (auxBreakPtr != NULL) {
auxBreakPtr = envPtr->exceptAuxArrayPtr + breakRange;
}
if (auxContinuePtr != NULL) {
auxContinuePtr = envPtr->exceptAuxArrayPtr + continueRange;
|
| ︙ | ︙ | |||
4393 4394 4395 4396 4397 4398 4399 |
ByteCode *codePtr, /* ByteCode in which to encode envPtr's
* command location information. */
unsigned char *startPtr) /* Points to the first byte in codePtr's
* memory block where the location information
* is to be stored. */
{
CmdLocation *mapPtr = envPtr->cmdMapPtr;
| > | < | | | | 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 |
ByteCode *codePtr, /* ByteCode in which to encode envPtr's
* command location information. */
unsigned char *startPtr) /* Points to the first byte in codePtr's
* memory block where the location information
* is to be stored. */
{
CmdLocation *mapPtr = envPtr->cmdMapPtr;
size_t i, codeDelta, codeLen, srcLen, prevOffset;
size_t numCmds = envPtr->numCommands;
unsigned char *p = startPtr;
int srcDelta;
/*
* Encode the code offset for each command as a sequence of deltas.
*/
codePtr->codeDeltaStart = p;
prevOffset = 0;
for (i = 0; i < numCmds; i++) {
codeDelta = mapPtr[i].codeOffset - prevOffset;
if (codeDelta == TCL_INDEX_NONE) {
Tcl_Panic("EncodeCmdLocMap: bad code offset");
} else if (codeDelta <= 127) {
TclStoreInt1AtPtr(codeDelta, p);
p++;
} else {
TclStoreInt1AtPtr(0xFF, p);
p++;
TclStoreInt4AtPtr(codeDelta, p);
p += 4;
}
prevOffset = mapPtr[i].codeOffset;
}
/*
* Encode the code length for each command.
*/
codePtr->codeLengthStart = p;
for (i = 0; i < numCmds; i++) {
codeLen = mapPtr[i].numCodeBytes;
if (codeLen == TCL_INDEX_NONE) {
Tcl_Panic("EncodeCmdLocMap: bad code length");
} else if (codeLen <= 127) {
TclStoreInt1AtPtr(codeLen, p);
p++;
} else {
TclStoreInt1AtPtr(0xFF, p);
p++;
|
| ︙ | ︙ | |||
4467 4468 4469 4470 4471 4472 4473 |
/*
* Encode the source length for each command.
*/
codePtr->srcLengthStart = p;
for (i = 0; i < numCmds; i++) {
srcLen = mapPtr[i].numSrcBytes;
| | | 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 |
/*
* Encode the source length for each command.
*/
codePtr->srcLengthStart = p;
for (i = 0; i < numCmds; i++) {
srcLen = mapPtr[i].numSrcBytes;
if (srcLen == TCL_INDEX_NONE) {
Tcl_Panic("EncodeCmdLocMap: bad source length");
} else if (srcLen <= 127) {
TclStoreInt1AtPtr(srcLen, p);
p++;
} else {
TclStoreInt1AtPtr(0xFF, p);
p++;
|
| ︙ | ︙ | |||
4519 4520 4521 4522 4523 4524 4525 |
if (iPtr == NULL) {
/* Avoid segfaulting in case we're called in a deleted interp */
return;
}
statsPtr = &(iPtr->stats);
statsPtr->numCompilations++;
| | | | | 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 |
if (iPtr == NULL) {
/* Avoid segfaulting in case we're called in a deleted interp */
return;
}
statsPtr = &(iPtr->stats);
statsPtr->numCompilations++;
statsPtr->totalSrcBytes += (double)codePtr->numSrcBytes;
statsPtr->totalByteCodeBytes += (double) codePtr->structureSize;
statsPtr->currentSrcBytes += (double) (int)codePtr->numSrcBytes;
statsPtr->currentByteCodeBytes += (double) codePtr->structureSize;
statsPtr->srcCount[TclLog2((int)codePtr->numSrcBytes)]++;
statsPtr->byteCodeCount[TclLog2((int) codePtr->structureSize)]++;
statsPtr->currentInstBytes += (double) codePtr->numCodeBytes;
statsPtr->currentLitBytes += (double)
codePtr->numLitObjects * sizeof(Tcl_Obj *);
statsPtr->currentExceptBytes += (double)
codePtr->numExceptRanges * sizeof(ExceptionRange);
|
| ︙ | ︙ |
Changes to generic/tclCompile.h.
| ︙ | ︙ | |||
85 86 87 88 89 90 91 |
CATCH_EXCEPTION_RANGE /* Exception's range is controlled by a catch
* command. Errors in the range cause a jump
* to a catch PC offset. */
} ExceptionRangeType;
typedef struct {
ExceptionRangeType type; /* The kind of ExceptionRange. */
| | | | | | | | | | | | | | | | | | | | | | | | 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 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 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 |
CATCH_EXCEPTION_RANGE /* Exception's range is controlled by a catch
* command. Errors in the range cause a jump
* to a catch PC offset. */
} ExceptionRangeType;
typedef struct {
ExceptionRangeType type; /* The kind of ExceptionRange. */
size_t nestingLevel; /* Static depth of the exception range. Used
* to find the most deeply-nested range
* surrounding a PC at runtime. */
size_t codeOffset; /* Offset of the first instruction byte of the
* code range. */
size_t numCodeBytes; /* Number of bytes in the code range. */
size_t breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC
* offset for a break command in the range. */
size_t continueOffset; /* If LOOP_EXCEPTION_RANGE and not TCL_INDEX_NONE, the
* target PC offset for a continue command in
* the code range. Otherwise, ignore this
* range when processing a continue
* command. */
size_t catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC
* offset for any "exception" in range. */
} ExceptionRange;
/*
* Auxiliary data used when issuing (currently just loop) exception ranges,
* but which is not required during execution.
*/
typedef struct ExceptionAux {
int supportsContinue; /* Whether this exception range will have a
* continueOffset created for it; if it is a
* loop exception range that *doesn't* have
* one (see [for] next-clause) then we must
* not pick up the range when scanning for a
* target to continue to. */
size_t stackDepth; /* The stack depth at the point where the
* exception range was created. This is used
* to calculate the number of POPs required to
* restore the stack to its prior state. */
size_t expandTarget; /* The number of expansions expected on the
* auxData stack at the time the loop starts;
* we can't currently discard them except by
* doing INST_INVOKE_EXPANDED; this is a known
* problem. */
size_t expandTargetDepth; /* The stack depth expected at the outermost
* expansion within the loop. Not meaningful
* if there are no open expansions between the
* looping level and the point of jump
* issue. */
size_t numBreakTargets; /* The number of [break]s that want to be
* targeted to the place where this loop
* exception will be bound to. */
TCL_HASH_TYPE *breakTargets; /* The offsets of the INST_JUMP4 instructions
* issued by the [break]s that we must
* update. Note that resizing a jump (via
* TclFixupForwardJump) can cause the contents
* of this array to be updated. When
* numBreakTargets==0, this is NULL. */
size_t allocBreakTargets; /* The size of the breakTargets array. */
size_t numContinueTargets; /* The number of [continue]s that want to be
* targeted to the place where this loop
* exception will be bound to. */
TCL_HASH_TYPE *continueTargets; /* The offsets of the INST_JUMP4 instructions
* issued by the [continue]s that we must
* update. Note that resizing a jump (via
* TclFixupForwardJump) can cause the contents
* of this array to be updated. When
* numContinueTargets==0, this is NULL. */
size_t allocContinueTargets; /* The size of the continueTargets array. */
} ExceptionAux;
/*
* Structure used to map between instruction pc and source locations. It
* defines for each compiled Tcl command its code's starting offset and its
* source's starting offset and length. Note that the code offset increases
* monotonically: that is, the table is sorted in code offset order. The
* source offset is not monotonic.
*/
typedef struct {
size_t codeOffset; /* Offset of first byte of command code. */
size_t numCodeBytes; /* Number of bytes for command's code. */
size_t srcOffset; /* Offset of first char of the command. */
size_t numSrcBytes; /* Number of command source chars. */
} CmdLocation;
/*
* TIP #280
* Structure to record additional location information for byte code. This
* information is internal and not saved. i.e. tbcload'ed code will not have
* this information. It records the lines for all words of all commands found
* in the byte code. The association with a ByteCode structure BC is done
* through the 'lineBCPtr' HashTable in Interp, keyed by the address of BC.
* Also recorded is information coming from the context, i.e. type of the
* frame and associated information, like the path of a sourced file.
*/
typedef struct {
size_t srcOffset; /* Command location to find the entry. */
size_t nline; /* Number of words in the command */
int *line; /* Line information for all words in the
* command. */
int **next; /* Transient information used by the compiler
* for tracking of hidden continuation
* lines. */
} ECL;
typedef struct {
int type; /* Context type. */
int start; /* Starting line for compiled script. Needed
* for the extended recompile check in
* tclCompileObj. */
Tcl_Obj *path; /* Path of the sourced file the command is
* in. */
ECL *loc; /* Command word locations (lines). */
size_t nloc; /* Number of allocated entries in 'loc'. */
size_t nuloc; /* Number of used entries in 'loc'. */
} ExtCmdLoc;
/*
* CompileProcs need the ability to record information during compilation that
* can be used by bytecode instructions during execution. The AuxData
* structure provides this "auxiliary data" mechanism. An arbitrary number of
* these structures can be stored in the ByteCode record (during compilation
|
| ︙ | ︙ | |||
217 218 219 220 221 222 223 | * the AuxData structure. */ typedef void *(AuxDataDupProc) (void *clientData); typedef void (AuxDataFreeProc) (void *clientData); typedef void (AuxDataPrintProc)(void *clientData, Tcl_Obj *appendObj, struct ByteCode *codePtr, | | | 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 | * the AuxData structure. */ typedef void *(AuxDataDupProc) (void *clientData); typedef void (AuxDataFreeProc) (void *clientData); typedef void (AuxDataPrintProc)(void *clientData, Tcl_Obj *appendObj, struct ByteCode *codePtr, TCL_HASH_TYPE pcOffset); /* * We define a separate AuxDataType struct to hold type-related information * for the AuxData structure. This separation makes it possible for clients * outside of the TCL core to manipulate (in a limited fashion!) AuxData; for * example, it makes it possible to pickle and unpickle AuxData structs. */ |
| ︙ | ︙ | |||
286 287 288 289 290 291 292 |
* compiled. Commands and their compile procs
* are specific to an interpreter so the code
* emitted will depend on the interpreter. */
const char *source; /* The source string being compiled by
* SetByteCodeFromAny. This pointer is not
* owned by the CompileEnv and must not be
* freed or changed by it. */
| | | | | | | > > > > | | | | > | < > | > > > > | | > | < > | | | 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 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 |
* compiled. Commands and their compile procs
* are specific to an interpreter so the code
* emitted will depend on the interpreter. */
const char *source; /* The source string being compiled by
* SetByteCodeFromAny. This pointer is not
* owned by the CompileEnv and must not be
* freed or changed by it. */
size_t numSrcBytes; /* Number of bytes in source. */
Proc *procPtr; /* If a procedure is being compiled, a pointer
* to its Proc structure; otherwise NULL. Used
* to compile local variables. Set from
* information provided by ObjInterpProc in
* tclProc.c. */
size_t numCommands; /* Number of commands compiled. */
size_t exceptDepth; /* Current exception range nesting level; TCL_INDEX_NONE
* if not in any range currently. */
size_t maxExceptDepth; /* Max nesting level of exception ranges; TCL_INDEX_NONE
* if no ranges have been compiled. */
size_t maxStackDepth; /* Maximum number of stack elements needed to
* execute the code. Set by compilation
* procedures before returning. */
size_t currStackDepth; /* Current stack depth. */
LiteralTable localLitTable; /* Contains LiteralEntry's describing all Tcl
* objects referenced by this compiled code.
* Indexed by the string representations of
* the literals. Used to avoid creating
* duplicate objects. */
unsigned char *codeStart; /* Points to the first byte of the code. */
unsigned char *codeNext; /* Points to next code array byte to use. */
unsigned char *codeEnd; /* Points just after the last allocated code
* array byte. */
int mallocedCodeArray; /* Set 1 if code array was expanded and
* codeStart points into the heap.*/
#if TCL_MAJOR_VERSION > 8
int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and
* exceptArrayPtr points in heap, else 0. */
#endif
LiteralEntry *literalArrayPtr;
/* Points to start of LiteralEntry array. */
size_t literalArrayNext; /* Index of next free object array entry. */
size_t literalArrayEnd; /* Index just after last obj array entry. */
int mallocedLiteralArray; /* 1 if object array was expanded and objArray
* points into the heap, else 0. */
ExceptionRange *exceptArrayPtr;
/* Points to start of the ExceptionRange
* array. */
size_t exceptArrayNext; /* Next free ExceptionRange array index.
* exceptArrayNext is the number of ranges and
* (exceptArrayNext-1) is the index of the
* current range's array entry. */
size_t exceptArrayEnd; /* Index after the last ExceptionRange array
* entry. */
#if TCL_MAJOR_VERSION < 9
int mallocedExceptArray;
#endif
ExceptionAux *exceptAuxArrayPtr;
/* Array of information used to restore the
* state when processing BREAK/CONTINUE
* exceptions. Must be the same size as the
* exceptArrayPtr. */
CmdLocation *cmdMapPtr; /* Points to start of CmdLocation array.
* numCommands is the index of the next entry
* to use; (numCommands-1) is the entry index
* for the last command. */
size_t cmdMapEnd; /* Index after last CmdLocation entry. */
int mallocedCmdMap; /* 1 if command map array was expanded and
* cmdMapPtr points in the heap, else 0. */
#if TCL_MAJOR_VERSION > 8
int mallocedAuxDataArray; /* 1 if aux data array was expanded and
* auxDataArrayPtr points in heap else 0. */
#endif
AuxData *auxDataArrayPtr; /* Points to auxiliary data array start. */
size_t auxDataArrayNext; /* Next free compile aux data array index.
* auxDataArrayNext is the number of aux data
* items and (auxDataArrayNext-1) is index of
* current aux data array entry. */
size_t auxDataArrayEnd; /* Index after last aux data array entry. */
#if TCL_MAJOR_VERSION < 9
int mallocedAuxDataArray;
#endif
unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES];
/* Initial storage for code. */
LiteralEntry staticLiteralSpace[COMPILEENV_INIT_NUM_OBJECTS];
/* Initial storage of LiteralEntry array. */
ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES];
/* Initial ExceptionRange array storage. */
ExceptionAux staticExAuxArraySpace[COMPILEENV_INIT_EXCEPT_RANGES];
/* Initial static except auxiliary info array
* storage. */
CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE];
/* Initial storage for cmd location map. */
AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE];
/* Initial storage for aux data array. */
/* TIP #280 */
ExtCmdLoc *extCmdMapPtr; /* Extended command location information for
* 'info frame'. */
size_t line; /* First line of the script, based on the
* invoking context, then the line of the
* command currently compiled. */
int atCmdStart; /* Flag to say whether an INST_START_CMD
* should be issued; they should never be
* issued repeatedly, as that is significantly
* inefficient. If set to 2, that instruction
* should not be issued at all (by the generic
* part of the command compiler). */
size_t expandCount; /* Number of INST_EXPAND_START instructions
* encountered that have not yet been paired
* with a corresponding
* INST_INVOKE_EXPANDED. */
int *clNext; /* If not NULL, it refers to the next slot in
* clLoc to check for an invisible
* continuation line. */
} CompileEnv;
|
| ︙ | ︙ | |||
413 414 415 416 417 418 419 |
typedef struct ByteCode {
TclHandle interpHandle; /* Handle for interpreter containing the
* compiled code. Commands and their compile
* procs are specific to an interpreter so the
* code emitted will depend on the
* interpreter. */
| | | 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 |
typedef struct ByteCode {
TclHandle interpHandle; /* Handle for interpreter containing the
* compiled code. Commands and their compile
* procs are specific to an interpreter so the
* code emitted will depend on the
* interpreter. */
size_t compileEpoch; /* Value of iPtr->compileEpoch when this
* ByteCode was compiled. Used to invalidate
* code when, e.g., commands with compile
* procs are redefined. */
Namespace *nsPtr; /* Namespace context in which this code was
* compiled. If the code is executed if a
* different namespace, it must be
* recompiled. */
|
| ︙ | ︙ | |||
445 446 447 448 449 450 451 |
* Proc structure; otherwise NULL. This
* pointer is also not owned by the ByteCode
* and must not be freed by it. */
size_t structureSize; /* Number of bytes in the ByteCode structure
* itself. Does not include heap space for
* literal Tcl objects or storage referenced
* by AuxData entries. */
| | | | | | | | | | | | 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 |
* Proc structure; otherwise NULL. This
* pointer is also not owned by the ByteCode
* and must not be freed by it. */
size_t structureSize; /* Number of bytes in the ByteCode structure
* itself. Does not include heap space for
* literal Tcl objects or storage referenced
* by AuxData entries. */
size_t numCommands; /* Number of commands compiled. */
size_t numSrcBytes; /* Number of source bytes compiled. */
size_t numCodeBytes; /* Number of code bytes. */
size_t numLitObjects; /* Number of objects in literal array. */
size_t numExceptRanges; /* Number of ExceptionRange array elems. */
size_t numAuxDataItems; /* Number of AuxData items. */
size_t numCmdLocBytes; /* Number of bytes needed for encoded command
* location information. */
size_t maxExceptDepth; /* Maximum nesting level of ExceptionRanges;
* TCL_INDEX_NONE if no ranges were compiled. */
size_t maxStackDepth; /* Maximum number of stack elements needed to
* execute the code. */
unsigned char *codeStart; /* Points to the first byte of the code. This
* is just after the final ByteCode member
* cmdMapPtr. */
Tcl_Obj **objArrayPtr; /* Points to the start of the literal object
* array. This is just after the last code
* byte. */
|
| ︙ | ︙ | |||
949 950 951 952 953 954 955 |
* to 5 bytes. */
} JumpFixup;
#define JUMPFIXUP_INIT_ENTRIES 10
typedef struct JumpFixupArray {
JumpFixup *fixup; /* Points to start of jump fixup array. */
| | | | | 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 |
* to 5 bytes. */
} JumpFixup;
#define JUMPFIXUP_INIT_ENTRIES 10
typedef struct JumpFixupArray {
JumpFixup *fixup; /* Points to start of jump fixup array. */
size_t next; /* Index of next free array entry. */
size_t end; /* Index of last usable entry in array. */
int mallocedArray; /* 1 if array was expanded and fixups points
* into the heap, else 0. */
JumpFixup staticFixupSpace[JUMPFIXUP_INIT_ENTRIES];
/* Initial storage for jump fixup array. */
} JumpFixupArray;
/*
* The structure describing one variable list of a foreach command. Note that
* only foreach commands inside procedure bodies are compiled inline so a
* ForeachVarList structure always describes local variables. Furthermore,
* only scalar variables are supported for inline-compiled foreach loops.
*/
typedef struct ForeachVarList {
size_t numVars; /* The number of variables in the list. */
size_t varIndexes[TCLFLEXARRAY];/* An array of the indexes ("slot numbers")
* for each variable in the procedure's array
* of local variables. Only scalar variables
* are supported. The actual size of this
* field will be large enough to numVars
* indexes. THIS MUST BE THE LAST FIELD IN THE
* STRUCTURE! */
} ForeachVarList;
|
| ︙ | ︙ | |||
1021 1022 1023 1024 1025 1026 1027 |
* Structure used to hold information about a [dict update] command that is
* needed during program execution. These structures are stored in CompileEnv
* and ByteCode structures as auxiliary data.
*/
typedef struct {
size_t length; /* Size of array */
| | | 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 |
* Structure used to hold information about a [dict update] command that is
* needed during program execution. These structures are stored in CompileEnv
* and ByteCode structures as auxiliary data.
*/
typedef struct {
size_t length; /* Size of array */
size_t varIndices[TCLFLEXARRAY]; /* Array of variable indices to manage when
* processing the start and end of a [dict
* update]. There is really more than one
* entry, and the structure is allocated to
* take account of this. MUST BE LAST FIELD IN
* STRUCTURE. */
} DictUpdateInfo;
|
| ︙ | ︙ | |||
1067 1068 1069 1070 1071 1072 1073 | *---------------------------------------------------------------- * Procedures shared among Tcl bytecode compilation and execution modules but * not used outside: *---------------------------------------------------------------- */ MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, | | | | | | | | | | | 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 | *---------------------------------------------------------------- * Procedures shared among Tcl bytecode compilation and execution modules but * not used outside: *---------------------------------------------------------------- */ MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, Tcl_Parse *parsePtr, size_t depth, Command *cmdPtr, CompileEnv *envPtr); MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, ExceptionAux *auxPtr); MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, Tcl_Token *tokenPtr, size_t count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script, size_t numBytes, CompileEnv *envPtr, int optimize); MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp, Tcl_Token *tokenPtr, size_t numWords, CompileEnv *envPtr); MODULE_SCOPE void TclCompileInvocation(Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, size_t numWords, CompileEnv *envPtr); MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp, const char *script, size_t numBytes, CompileEnv *envPtr); MODULE_SCOPE void TclCompileSyntaxError(Tcl_Interp *interp, CompileEnv *envPtr); MODULE_SCOPE void TclCompileTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, size_t count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileVarSubst(Tcl_Interp *interp, Tcl_Token *tokenPtr, CompileEnv *envPtr); MODULE_SCOPE size_t TclCreateAuxData(void *clientData, const AuxDataType *typePtr, CompileEnv *envPtr); MODULE_SCOPE size_t TclCreateExceptRange(ExceptionRangeType type, CompileEnv *envPtr); MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, size_t size); MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes, size_t length, TCL_HASH_TYPE hash, int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr); MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr); MODULE_SCOPE void TclDeleteLiteralTable(Tcl_Interp *interp, LiteralTable *tablePtr); MODULE_SCOPE void TclEmitForwardJump(CompileEnv *envPtr, TclJumpType jumpType, JumpFixup *jumpFixupPtr); MODULE_SCOPE void TclEmitInvoke(CompileEnv *envPtr, int opcode, ...); MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc, int catchOnly, ByteCode *codePtr); MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, ByteCode *codePtr); MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, TCL_HASH_TYPE index); MODULE_SCOPE size_t TclFindCompiledLocal(const char *name, size_t nameChars, int create, CompileEnv *envPtr); MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, JumpFixup *jumpFixupPtr, int jumpDist, int distThreshold); MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr); MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclGetIndexFromToken(Tcl_Token *tokenPtr, |
| ︙ | ︙ | |||
1142 1143 1144 1145 1146 1147 1148 | ExceptionAux *auxPtr); MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr, int range); #ifdef TCL_COMPILE_STATS MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr); MODULE_SCOPE int TclLog2(int value); #endif | | | | 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 | ExceptionAux *auxPtr); MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr, int range); #ifdef TCL_COMPILE_STATS MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr); MODULE_SCOPE int TclLog2(int value); #endif MODULE_SCOPE size_t TclLocalScalar(const char *bytes, size_t numBytes, CompileEnv *envPtr); MODULE_SCOPE size_t TclLocalScalarFromToken(Tcl_Token *tokenPtr, CompileEnv *envPtr); MODULE_SCOPE void TclOptimizeBytecode(void *envPtr); #ifdef TCL_COMPILE_DEBUG MODULE_SCOPE void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr); #endif MODULE_SCOPE int TclPrintInstruction(ByteCode *codePtr, |
| ︙ | ︙ | |||
1166 1167 1168 1169 1170 1171 1172 | int flags, int *localIndexPtr, int *isScalarPtr); MODULE_SCOPE void TclPreserveByteCode(ByteCode *codePtr); MODULE_SCOPE void TclReleaseByteCode(ByteCode *codePtr); MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp, const char *name, Namespace *nsPtr); | | < < | < < | < < | < < | | 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 | int flags, int *localIndexPtr, int *isScalarPtr); MODULE_SCOPE void TclPreserveByteCode(ByteCode *codePtr); MODULE_SCOPE void TclReleaseByteCode(ByteCode *codePtr); MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp, const char *name, Namespace *nsPtr); MODULE_SCOPE Tcl_ObjCmdProc TclSingleOpCmd; MODULE_SCOPE Tcl_ObjCmdProc TclSortingOpCmd; MODULE_SCOPE Tcl_ObjCmdProc TclVariadicOpCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNoIdentOpCmd; #ifdef TCL_COMPILE_DEBUG MODULE_SCOPE void TclVerifyGlobalLiteralTable(Interp *iPtr); MODULE_SCOPE void TclVerifyLocalLiteralTable(CompileEnv *envPtr); #endif MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr, Tcl_Obj *valuePtr); MODULE_SCOPE void TclLogCommandInfo(Tcl_Interp *interp, const char *script, const char *command, size_t length, const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); MODULE_SCOPE int TclPushProcCallFrame(void *clientData, Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int isLambda); /* *---------------------------------------------------------------- * Macros and flag values used by Tcl bytecode compilation and execution * modules inside the Tcl core but not used outside. |
| ︙ | ︙ | |||
1227 1228 1229 1230 1231 1232 1233 |
*
* void TclAdjustStackDepth(int delta, CompileEnv *envPtr);
*/
#define TclAdjustStackDepth(delta, envPtr) \
do { \
if ((delta) < 0) { \
| | | | | 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 |
*
* void TclAdjustStackDepth(int delta, CompileEnv *envPtr);
*/
#define TclAdjustStackDepth(delta, envPtr) \
do { \
if ((delta) < 0) { \
if ((int)(envPtr)->maxStackDepth < (int)(envPtr)->currStackDepth) { \
(envPtr)->maxStackDepth = (envPtr)->currStackDepth; \
} \
} \
(envPtr)->currStackDepth += (delta); \
} while (0)
#define TclGetStackDepth(envPtr) \
((envPtr)->currStackDepth)
#define TclSetStackDepth(depth, envPtr) \
(envPtr)->currStackDepth = (depth)
#define TclCheckStackDepth(depth, envPtr) \
do { \
size_t _dd = (depth); \
if (_dd != (envPtr)->currStackDepth) { \
Tcl_Panic("bad stack depth computations: is %" TCL_Z_MODIFIER "u, should be %" TCL_Z_MODIFIER "u", \
(envPtr)->currStackDepth, _dd); \
} \
} while (0)
/*
* Macro used to update the stack requirements. It is called by the macros
* TclEmitOpCode, TclEmitInst1 and TclEmitInst4.
|
| ︙ | ︙ | |||
1440 1441 1442 1443 1444 1445 1446 |
*
* int TclFixupForwardJumpToHere(CompileEnv *envPtr, JumpFixup *fixupPtr,
* int threshold);
*/
#define TclFixupForwardJumpToHere(envPtr, fixupPtr, threshold) \
TclFixupForwardJump((envPtr), (fixupPtr), \
| | | 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 |
*
* int TclFixupForwardJumpToHere(CompileEnv *envPtr, JumpFixup *fixupPtr,
* int threshold);
*/
#define TclFixupForwardJumpToHere(envPtr, fixupPtr, threshold) \
TclFixupForwardJump((envPtr), (fixupPtr), \
(envPtr)->codeNext-(envPtr)->codeStart-(int)(fixupPtr)->codeOffset, \
(threshold))
/*
* Macros to get a signed integer (GET_INT{1,2}) or an unsigned int
* (GET_UINT{1,2}) from a pointer. There are two variants for each return type
* that depend on the number of bytes fetched. The ANSI C "prototypes" for
* these macros are:
|
| ︙ | ︙ | |||
1487 1488 1489 1490 1491 1492 1493 |
#define TclGetUInt4AtPtr(p) \
((unsigned int) ((*(p) << 24) | \
(*((p)+1) << 16) | \
(*((p)+2) << 8) | \
(*((p)+3))))
/*
| | | | | | | 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 |
#define TclGetUInt4AtPtr(p) \
((unsigned int) ((*(p) << 24) | \
(*((p)+1) << 16) | \
(*((p)+2) << 8) | \
(*((p)+3))))
/*
* Macros used to compute the minimum and maximum of two values. The ANSI C
* "prototypes" for these macros are:
*
* size_t TclMin(size_t i, size_t j);
* size_t TclMax(size_t i, size_t j);
*/
#define TclMin(i, j) ((((size_t) i) + 1 < ((size_t) j) + 1 )? (i) : (j))
#define TclMax(i, j) ((((size_t) i) + 1 > ((size_t) j) + 1 )? (i) : (j))
/*
* Convenience macros for use when compiling bodies of commands. The ANSI C
* "prototype" for these macros are:
*
* static void BODY(Tcl_Token *tokenPtr, int word);
*/
|
| ︙ | ︙ | |||
1562 1563 1564 1565 1566 1567 1568 | /* * Note: the exceptDepth is a bit of a misnomer: TEBC only needs the * maximal depth of nested CATCH ranges in order to alloc runtime * memory. These macros should compute precisely that? OTOH, the nesting depth * of LOOP ranges is an interesting datum for debugging purposes, and that is * what we compute now. * | | | | | | | 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 |
/*
* Note: the exceptDepth is a bit of a misnomer: TEBC only needs the
* maximal depth of nested CATCH ranges in order to alloc runtime
* memory. These macros should compute precisely that? OTOH, the nesting depth
* of LOOP ranges is an interesting datum for debugging purposes, and that is
* what we compute now.
*
* static int ExceptionRangeStarts(CompileEnv *envPtr, size_t index);
* static void ExceptionRangeEnds(CompileEnv *envPtr, size_t index);
* static void ExceptionRangeTarget(CompileEnv *envPtr, size_t index, LABEL);
*/
#define ExceptionRangeStarts(envPtr, index) \
(((envPtr)->exceptDepth++), \
((envPtr)->maxExceptDepth = \
TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \
((envPtr)->exceptArrayPtr[(index)].codeOffset= CurrentOffset(envPtr)))
#define ExceptionRangeEnds(envPtr, index) \
(((envPtr)->exceptDepth--), \
((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \
CurrentOffset(envPtr) - (int)(envPtr)->exceptArrayPtr[(index)].codeOffset))
#define ExceptionRangeTarget(envPtr, index, targetType) \
((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr))
/*
* Check if there is an LVT for compiled locals
*/
|
| ︙ | ︙ | |||
1623 1624 1625 1626 1627 1628 1629 |
* change during the course of the function.
*
* Macro to encapsulate the variable definition and setup.
*/
#define DefineLineInformation \
ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
| | | 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 |
* change during the course of the function.
*
* Macro to encapsulate the variable definition and setup.
*/
#define DefineLineInformation \
ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
size_t eclIndex = mapPtr->nuloc - 1
#define SetLineInformation(word) \
envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \
envPtr->clNext = mapPtr->loc[eclIndex].next[(word)]
#define PushVarNameWord(i,v,e,f,l,sc,word) \
SetLineInformation(word); \
|
| ︙ | ︙ |
Changes to generic/tclConfig.c.
| ︙ | ︙ | |||
187 188 189 190 191 192 193 | * See the manual for what this command does. * *---------------------------------------------------------------------- */ static int QueryConfigObjCmd( | | | | < | 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 |
* See the manual for what this command does.
*
*----------------------------------------------------------------------
*/
static int
QueryConfigObjCmd(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
QCCD *cdPtr = (QCCD *)clientData;
Tcl_Obj *pkgName = cdPtr->pkg;
Tcl_Obj *pDB, *pkgDict, *val, *listPtr;
size_t m, n = 0;
static const char *const subcmdStrings[] = {
"get", "list", NULL
};
enum subcmds {
CFG_GET, CFG_LIST
} index;
Tcl_DString conv;
|
| ︙ | ︙ | |||
318 319 320 321 322 323 324 | * Deallocates all non-transient memory allocated by Tcl_RegisterConfig. * *------------------------------------------------------------------------- */ static void QueryConfigDelete( | | | 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 |
* Deallocates all non-transient memory allocated by Tcl_RegisterConfig.
*
*-------------------------------------------------------------------------
*/
static void
QueryConfigDelete(
void *clientData)
{
QCCD *cdPtr = (QCCD *)clientData;
Tcl_Obj *pkgName = cdPtr->pkg;
Tcl_Obj *pDB = GetConfigDict(cdPtr->interp);
Tcl_DictObjRemove(NULL, pDB, pkgName);
Tcl_DecrRefCount(pkgName);
|
| ︙ | ︙ | |||
385 386 387 388 389 390 391 | * The package metadata database is freed. * *---------------------------------------------------------------------- */ static void ConfigDictDeleteProc( | | | 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 |
* The package metadata database is freed.
*
*----------------------------------------------------------------------
*/
static void
ConfigDictDeleteProc(
void *clientData, /* Pointer to Tcl_Obj. */
TCL_UNUSED(Tcl_Interp *))
{
Tcl_DecrRefCount((Tcl_Obj *)clientData);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclDate.c.
| ︙ | ︙ | |||
2741 2742 2743 2744 2745 2746 2747 |
}
}
int
TclClockOldscanObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
| | | 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 |
}
}
int
TclClockOldscanObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Count of parameters */
Tcl_Obj *const *objv) /* Parameters */
{
Tcl_Obj *result, *resultElement;
int yr, mo, da;
DateInfo dateInfo;
DateInfo* info = &dateInfo;
int status;
|
| ︙ | ︙ |
Changes to generic/tclDecls.h.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 | /* 1 */ EXTERN const char * Tcl_PkgRequireEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 2 */ EXTERN TCL_NORETURN void Tcl_Panic(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 3 */ | | | | | | 57 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 | /* 1 */ EXTERN const char * Tcl_PkgRequireEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 2 */ EXTERN TCL_NORETURN void Tcl_Panic(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 3 */ EXTERN void * Tcl_Alloc(TCL_HASH_TYPE size); /* 4 */ EXTERN void Tcl_Free(void *ptr); /* 5 */ EXTERN void * Tcl_Realloc(void *ptr, TCL_HASH_TYPE size); /* 6 */ EXTERN void * Tcl_DbCkalloc(TCL_HASH_TYPE size, const char *file, int line); /* 7 */ EXTERN void Tcl_DbCkfree(void *ptr, const char *file, int line); /* 8 */ EXTERN void * Tcl_DbCkrealloc(void *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 9 */ EXTERN void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, void *clientData); /* 10 */ EXTERN void Tcl_DeleteFileHandler(int fd); /* 11 */ |
| ︙ | ︙ | |||
90 91 92 93 94 95 96 | Tcl_Obj *objPtr); /* 15 */ EXTERN void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...); /* 16 */ EXTERN void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, size_t length); /* 17 */ | | | | | 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 | Tcl_Obj *objPtr); /* 15 */ EXTERN void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...); /* 16 */ EXTERN void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, size_t length); /* 17 */ EXTERN Tcl_Obj * Tcl_ConcatObj(size_t objc, Tcl_Obj *const objv[]); /* 18 */ EXTERN int Tcl_ConvertToType(Tcl_Interp *interp, Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 19 */ EXTERN void Tcl_DbDecrRefCount(Tcl_Obj *objPtr, const char *file, int line); /* 20 */ EXTERN void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, int line); /* 21 */ EXTERN int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line); /* Slot 22 is reserved */ /* 23 */ EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes, size_t numBytes, const char *file, int line); /* 24 */ EXTERN Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue, const char *file, int line); /* 25 */ EXTERN Tcl_Obj * Tcl_DbNewListObj(size_t objc, Tcl_Obj *const *objv, const char *file, int line); /* Slot 26 is reserved */ /* 27 */ EXTERN Tcl_Obj * Tcl_DbNewObj(const char *file, int line); /* 28 */ EXTERN Tcl_Obj * Tcl_DbNewStringObj(const char *bytes, ssize_t length, const char *file, int line); /* 29 */ EXTERN Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr); /* 30 */ EXTERN void TclFreeObj(Tcl_Obj *objPtr); /* 31 */ EXTERN int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, int *intPtr); /* 32 */ EXTERN int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 33 */ EXTERN unsigned char * TclGetByteArrayFromObj(Tcl_Obj *objPtr, int *numBytesPtr); /* 34 */ EXTERN int Tcl_GetDouble(Tcl_Interp *interp, const char *src, double *doublePtr); /* 35 */ EXTERN int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* Slot 36 is reserved */ |
| ︙ | ︙ | |||
161 162 163 164 165 166 167 | /* 43 */ EXTERN int Tcl_ListObjAppendList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *elemListPtr); /* 44 */ EXTERN int Tcl_ListObjAppendElement(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *objPtr); /* 45 */ | | | | | | | | | 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 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 | /* 43 */ EXTERN int Tcl_ListObjAppendList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *elemListPtr); /* 44 */ EXTERN int Tcl_ListObjAppendElement(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *objPtr); /* 45 */ EXTERN int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, int *objcPtr, Tcl_Obj ***objvPtr); /* 46 */ EXTERN int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t index, Tcl_Obj **objPtrPtr); /* 47 */ EXTERN int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 48 */ EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t first, size_t count, size_t objc, Tcl_Obj *const objv[]); /* Slot 49 is reserved */ /* 50 */ EXTERN Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes, size_t numBytes); /* 51 */ EXTERN Tcl_Obj * Tcl_NewDoubleObj(double doubleValue); /* Slot 52 is reserved */ /* 53 */ EXTERN Tcl_Obj * Tcl_NewListObj(size_t objc, Tcl_Obj *const objv[]); /* Slot 54 is reserved */ /* 55 */ EXTERN Tcl_Obj * Tcl_NewObj(void); /* 56 */ EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, ssize_t length); /* Slot 57 is reserved */ /* 58 */ EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, size_t numBytes); /* 59 */ EXTERN void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, const unsigned char *bytes, size_t numBytes); /* 60 */ EXTERN void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue); /* Slot 61 is reserved */ /* 62 */ EXTERN void Tcl_SetListObj(Tcl_Obj *objPtr, size_t objc, Tcl_Obj *const objv[]); /* Slot 63 is reserved */ /* 64 */ EXTERN void Tcl_SetObjLength(Tcl_Obj *objPtr, size_t length); /* 65 */ EXTERN void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, size_t length); |
| ︙ | ︙ | |||
240 241 242 243 244 245 246 | const char *optionList); /* 79 */ EXTERN void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *clientData); /* 80 */ EXTERN void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, void *clientData); | | > | | | | 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 | const char *optionList); /* 79 */ EXTERN void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *clientData); /* 80 */ EXTERN void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, void *clientData); /* 81 */ EXTERN int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan); /* 82 */ EXTERN int Tcl_CommandComplete(const char *cmd); /* 83 */ EXTERN char * Tcl_Concat(size_t argc, const char *const *argv); /* 84 */ EXTERN size_t Tcl_ConvertElement(const char *src, char *dst, int flags); /* 85 */ EXTERN size_t Tcl_ConvertCountedElement(const char *src, size_t length, char *dst, int flags); /* 86 */ EXTERN int Tcl_CreateAlias(Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, size_t argc, const char *const *argv); /* 87 */ EXTERN int Tcl_CreateAliasObj(Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, size_t objc, Tcl_Obj *const objv[]); /* 88 */ EXTERN Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr, const char *chanName, void *instanceData, int mask); /* 89 */ EXTERN void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask, |
| ︙ | ︙ | |||
332 333 334 335 336 337 338 | /* 108 */ EXTERN void Tcl_DeleteHashEntry(Tcl_HashEntry *entryPtr); /* 109 */ EXTERN void Tcl_DeleteHashTable(Tcl_HashTable *tablePtr); /* 110 */ EXTERN void Tcl_DeleteInterp(Tcl_Interp *interp); /* 111 */ | | | 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 | /* 108 */ EXTERN void Tcl_DeleteHashEntry(Tcl_HashEntry *entryPtr); /* 109 */ EXTERN void Tcl_DeleteHashTable(Tcl_HashTable *tablePtr); /* 110 */ EXTERN void Tcl_DeleteInterp(Tcl_Interp *interp); /* 111 */ EXTERN void Tcl_DetachPids(size_t numPids, Tcl_Pid *pidPtr); /* 112 */ EXTERN void Tcl_DeleteTimerHandler(Tcl_TimerToken token); /* 113 */ EXTERN void Tcl_DeleteTrace(Tcl_Interp *interp, Tcl_Trace trace); /* 114 */ EXTERN void Tcl_DontCallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *clientData); |
| ︙ | ︙ | |||
439 440 441 442 443 444 445 | EXTERN void * Tcl_GetAssocData(Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 151 */ EXTERN Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, const char *chanName, int *modePtr); /* 152 */ | | | 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 | EXTERN void * Tcl_GetAssocData(Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 151 */ EXTERN Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, const char *chanName, int *modePtr); /* 152 */ EXTERN size_t Tcl_GetChannelBufferSize(Tcl_Channel chan); /* 153 */ EXTERN int Tcl_GetChannelHandle(Tcl_Channel chan, int direction, void **handlePtr); /* 154 */ EXTERN void * Tcl_GetChannelInstanceData(Tcl_Channel chan); /* 155 */ EXTERN int Tcl_GetChannelMode(Tcl_Channel chan); |
| ︙ | ︙ | |||
515 516 517 518 519 520 521 | /* 183 */ EXTERN int Tcl_InputBuffered(Tcl_Channel chan); /* 184 */ EXTERN int Tcl_InterpDeleted(Tcl_Interp *interp); /* 185 */ EXTERN int Tcl_IsSafe(Tcl_Interp *interp); /* 186 */ | | | | | | 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 | /* 183 */ EXTERN int Tcl_InputBuffered(Tcl_Channel chan); /* 184 */ EXTERN int Tcl_InterpDeleted(Tcl_Interp *interp); /* 185 */ EXTERN int Tcl_IsSafe(Tcl_Interp *interp); /* 186 */ EXTERN char * Tcl_JoinPath(size_t argc, const char *const *argv, Tcl_DString *resultPtr); /* 187 */ EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, void *addr, int type); /* Slot 188 is reserved */ /* 189 */ EXTERN Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode); /* 190 */ EXTERN int Tcl_MakeSafe(Tcl_Interp *interp); /* 191 */ EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket); /* 192 */ EXTERN char * Tcl_Merge(size_t argc, const char *const *argv); /* 193 */ EXTERN Tcl_HashEntry * Tcl_NextHashEntry(Tcl_HashSearch *searchPtr); /* 194 */ EXTERN void Tcl_NotifyChannel(Tcl_Channel channel, int mask); /* 195 */ EXTERN Tcl_Obj * Tcl_ObjGetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 196 */ EXTERN Tcl_Obj * Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 197 */ EXTERN Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, size_t argc, const char **argv, int flags); /* 198 */ EXTERN Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, const char *fileName, const char *modeString, int permissions); /* 199 */ EXTERN Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port, const char *address, const char *myaddr, |
| ︙ | ︙ | |||
566 567 568 569 570 571 572 | EXTERN void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst); /* 203 */ EXTERN int Tcl_PutEnv(const char *assignment); /* 204 */ EXTERN const char * Tcl_PosixError(Tcl_Interp *interp); /* 205 */ | | < | 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 | EXTERN void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst); /* 203 */ EXTERN int Tcl_PutEnv(const char *assignment); /* 204 */ EXTERN const char * Tcl_PosixError(Tcl_Interp *interp); /* 205 */ EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr, int position); /* 206 */ EXTERN size_t Tcl_Read(Tcl_Channel chan, char *bufPtr, size_t toRead); /* 207 */ EXTERN void Tcl_ReapDetachedProcs(void); /* 208 */ EXTERN int Tcl_RecordAndEval(Tcl_Interp *interp, |
| ︙ | ︙ | |||
615 616 617 618 619 620 621 | /* 222 */ EXTERN int Tcl_ServiceEvent(int flags); /* 223 */ EXTERN void Tcl_SetAssocData(Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, void *clientData); /* 224 */ | | | > | 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 | /* 222 */ EXTERN int Tcl_ServiceEvent(int flags); /* 223 */ EXTERN void Tcl_SetAssocData(Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, void *clientData); /* 224 */ EXTERN void Tcl_SetChannelBufferSize(Tcl_Channel chan, size_t sz); /* 225 */ EXTERN int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, const char *newValue); /* 226 */ EXTERN int Tcl_SetCommandInfo(Tcl_Interp *interp, const char *cmdName, const Tcl_CmdInfo *infoPtr); /* 227 */ EXTERN void Tcl_SetErrno(int err); /* 228 */ EXTERN void Tcl_SetErrorCode(Tcl_Interp *interp, ...); /* 229 */ EXTERN void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr); /* Slot 230 is reserved */ /* 231 */ EXTERN size_t Tcl_SetRecursionLimit(Tcl_Interp *interp, size_t depth); /* Slot 232 is reserved */ /* 233 */ EXTERN int Tcl_SetServiceMode(int mode); /* 234 */ EXTERN void Tcl_SetObjErrorCode(Tcl_Interp *interp, Tcl_Obj *errorObjPtr); /* 235 */ |
| ︙ | ︙ | |||
656 657 658 659 660 661 662 | /* 239 */ EXTERN const char * Tcl_SignalId(int sig); /* 240 */ EXTERN const char * Tcl_SignalMsg(int sig); /* 241 */ EXTERN void Tcl_SourceRCFile(Tcl_Interp *interp); /* 242 */ | | < | | | 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 | /* 239 */ EXTERN const char * Tcl_SignalId(int sig); /* 240 */ EXTERN const char * Tcl_SignalMsg(int sig); /* 241 */ EXTERN void Tcl_SourceRCFile(Tcl_Interp *interp); /* 242 */ EXTERN int TclSplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr, const char ***argvPtr); /* 243 */ EXTERN void TclSplitPath(const char *path, int *argcPtr, const char ***argvPtr); /* Slot 244 is reserved */ /* Slot 245 is reserved */ /* Slot 246 is reserved */ /* Slot 247 is reserved */ /* 248 */ EXTERN int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, |
| ︙ | ︙ | |||
712 713 714 715 716 717 718 | const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, void *prevClientData); /* 263 */ EXTERN ssize_t Tcl_Write(Tcl_Channel chan, const char *s, ssize_t slen); /* 264 */ | | | 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 | const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, void *prevClientData); /* 263 */ EXTERN ssize_t Tcl_Write(Tcl_Channel chan, const char *s, ssize_t slen); /* 264 */ EXTERN void Tcl_WrongNumArgs(Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], const char *message); /* 265 */ EXTERN int Tcl_DumpActiveMemory(const char *fileName); /* 266 */ EXTERN void Tcl_ValidateAllMemory(const char *file, int line); /* Slot 267 is reserved */ /* Slot 268 is reserved */ |
| ︙ | ︙ | |||
771 772 773 774 775 776 777 | EXTERN void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, void *clientData); /* Slot 290 is reserved */ /* 291 */ EXTERN int Tcl_EvalEx(Tcl_Interp *interp, const char *script, size_t numBytes, int flags); /* 292 */ | | | 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 | EXTERN void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, void *clientData); /* Slot 290 is reserved */ /* 291 */ EXTERN int Tcl_EvalEx(Tcl_Interp *interp, const char *script, size_t numBytes, int flags); /* 292 */ EXTERN int Tcl_EvalObjv(Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int flags); /* 293 */ EXTERN int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 294 */ EXTERN TCL_NORETURN void Tcl_ExitThread(int status); /* 295 */ |
| ︙ | ︙ | |||
843 844 845 846 847 848 849 | EXTERN Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 318 */ EXTERN void Tcl_ThreadAlert(Tcl_ThreadId threadId); /* 319 */ EXTERN void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, | | | 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 | EXTERN Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 318 */ EXTERN void Tcl_ThreadAlert(Tcl_ThreadId threadId); /* 319 */ EXTERN void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr, int position); /* 320 */ EXTERN int Tcl_UniCharAtIndex(const char *src, ssize_t index); /* 321 */ EXTERN int Tcl_UniCharToLower(int ch); /* 322 */ EXTERN int Tcl_UniCharToTitle(int ch); /* 323 */ |
| ︙ | ︙ | |||
1019 1020 1021 1022 1023 1024 1025 | /* 388 */ EXTERN int Tcl_GetChannelNames(Tcl_Interp *interp); /* 389 */ EXTERN int Tcl_GetChannelNamesEx(Tcl_Interp *interp, const char *pattern); /* 390 */ EXTERN int Tcl_ProcObjCmd(void *clientData, Tcl_Interp *interp, | | | 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 | /* 388 */ EXTERN int Tcl_GetChannelNames(Tcl_Interp *interp); /* 389 */ EXTERN int Tcl_GetChannelNamesEx(Tcl_Interp *interp, const char *pattern); /* 390 */ EXTERN int Tcl_ProcObjCmd(void *clientData, Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[]); /* 391 */ EXTERN void Tcl_ConditionFinalize(Tcl_Condition *condPtr); /* 392 */ EXTERN void Tcl_MutexFinalize(Tcl_Mutex *mutex); /* 393 */ EXTERN int Tcl_CreateThread(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, |
| ︙ | ︙ | |||
1113 1114 1115 1116 1117 1118 1119 | const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 427 */ EXTERN void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 428 */ | | | | | | | 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 | const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 427 */ EXTERN void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 428 */ EXTERN void * Tcl_AttemptAlloc(TCL_HASH_TYPE size); /* 429 */ EXTERN void * Tcl_AttemptDbCkalloc(TCL_HASH_TYPE size, const char *file, int line); /* 430 */ EXTERN void * Tcl_AttemptRealloc(void *ptr, TCL_HASH_TYPE size); /* 431 */ EXTERN void * Tcl_AttemptDbCkrealloc(void *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 432 */ EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, size_t length); /* 433 */ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel); /* 434 */ |
| ︙ | ︙ | |||
1198 1199 1200 1201 1202 1203 1204 | EXTERN Tcl_Obj * Tcl_FSGetCwd(Tcl_Interp *interp); /* 458 */ EXTERN int Tcl_FSChdir(Tcl_Obj *pathPtr); /* 459 */ EXTERN int Tcl_FSConvertToPathType(Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 460 */ | | | | | 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 | EXTERN Tcl_Obj * Tcl_FSGetCwd(Tcl_Interp *interp); /* 458 */ EXTERN int Tcl_FSChdir(Tcl_Obj *pathPtr); /* 459 */ EXTERN int Tcl_FSConvertToPathType(Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 460 */ EXTERN Tcl_Obj * Tcl_FSJoinPath(Tcl_Obj *listObj, size_t elements); /* 461 */ EXTERN Tcl_Obj * TclFSSplitPath(Tcl_Obj *pathPtr, int *lenPtr); /* 462 */ EXTERN int Tcl_FSEqualPaths(Tcl_Obj *firstPtr, Tcl_Obj *secondPtr); /* 463 */ EXTERN Tcl_Obj * Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 464 */ EXTERN Tcl_Obj * Tcl_FSJoinToPath(Tcl_Obj *pathPtr, size_t objc, Tcl_Obj *const objv[]); /* 465 */ EXTERN void * Tcl_FSGetInternalRep(Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr); /* 466 */ EXTERN Tcl_Obj * Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr); |
| ︙ | ︙ | |||
1295 1296 1297 1298 1299 1300 1301 | /* 495 */ EXTERN int Tcl_DictObjGet(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr, Tcl_Obj **valuePtrPtr); /* 496 */ EXTERN int Tcl_DictObjRemove(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr); /* 497 */ | | | | | 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 | /* 495 */ EXTERN int Tcl_DictObjGet(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr, Tcl_Obj **valuePtrPtr); /* 496 */ EXTERN int Tcl_DictObjRemove(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr); /* 497 */ EXTERN int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, int *sizePtr); /* 498 */ EXTERN int Tcl_DictObjFirst(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); /* 499 */ EXTERN void Tcl_DictObjNext(Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); /* 500 */ EXTERN void Tcl_DictObjDone(Tcl_DictSearch *searchPtr); /* 501 */ EXTERN int Tcl_DictObjPutKeyList(Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr); /* 502 */ EXTERN int Tcl_DictObjRemoveKeyList(Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t keyc, Tcl_Obj *const *keyv); /* 503 */ EXTERN Tcl_Obj * Tcl_NewDictObj(void); /* 504 */ EXTERN Tcl_Obj * Tcl_DbNewDictObj(const char *file, int line); /* 505 */ EXTERN void Tcl_RegisterConfig(Tcl_Interp *interp, |
| ︙ | ︙ | |||
1381 1382 1383 1384 1385 1386 1387 | EXTERN int Tcl_LimitReady(Tcl_Interp *interp); /* 523 */ EXTERN int Tcl_LimitCheck(Tcl_Interp *interp); /* 524 */ EXTERN int Tcl_LimitExceeded(Tcl_Interp *interp); /* 525 */ EXTERN void Tcl_LimitSetCommands(Tcl_Interp *interp, | | | 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 | EXTERN int Tcl_LimitReady(Tcl_Interp *interp); /* 523 */ EXTERN int Tcl_LimitCheck(Tcl_Interp *interp); /* 524 */ EXTERN int Tcl_LimitExceeded(Tcl_Interp *interp); /* 525 */ EXTERN void Tcl_LimitSetCommands(Tcl_Interp *interp, size_t commandLimit); /* 526 */ EXTERN void Tcl_LimitSetTime(Tcl_Interp *interp, Tcl_Time *timeLimitPtr); /* 527 */ EXTERN void Tcl_LimitSetGranularity(Tcl_Interp *interp, int type, int granularity); /* 528 */ |
| ︙ | ︙ | |||
1513 1514 1515 1516 1517 1518 1519 | /* 571 */ EXTERN int Tcl_SetEncodingSearchPath(Tcl_Obj *searchPath); /* 572 */ EXTERN const char * Tcl_GetEncodingNameFromEnvironment( Tcl_DString *bufPtr); /* 573 */ EXTERN int Tcl_PkgRequireProc(Tcl_Interp *interp, | | | | | 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 | /* 571 */ EXTERN int Tcl_SetEncodingSearchPath(Tcl_Obj *searchPath); /* 572 */ EXTERN const char * Tcl_GetEncodingNameFromEnvironment( Tcl_DString *bufPtr); /* 573 */ EXTERN int Tcl_PkgRequireProc(Tcl_Interp *interp, const char *name, size_t objc, Tcl_Obj *const objv[], void *clientDataPtr); /* 574 */ EXTERN void Tcl_AppendObjToErrorInfo(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 575 */ EXTERN void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, const char *bytes, size_t length, size_t limit, const char *ellipsis); /* 576 */ EXTERN Tcl_Obj * Tcl_Format(Tcl_Interp *interp, const char *format, size_t objc, Tcl_Obj *const objv[]); /* 577 */ EXTERN int Tcl_AppendFormatToObj(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, size_t objc, Tcl_Obj *const objv[]); /* 578 */ EXTERN Tcl_Obj * Tcl_ObjPrintf(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 579 */ EXTERN void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, const char *format, ...) TCL_FORMAT_PRINTF(2, 3); /* 580 */ EXTERN int Tcl_CancelEval(Tcl_Interp *interp, |
| ︙ | ︙ | |||
1553 1554 1555 1556 1557 1558 1559 | const char *cmdName, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 584 */ EXTERN int Tcl_NREvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 585 */ | | | > | | 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 | const char *cmdName, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 584 */ EXTERN int Tcl_NREvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 585 */ EXTERN int Tcl_NREvalObjv(Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int flags); /* 586 */ EXTERN int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd, size_t objc, Tcl_Obj *const objv[], int flags); /* 587 */ EXTERN void Tcl_NRAddCallback(Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr, void *data0, void *data1, void *data2, void *data3); /* 588 */ EXTERN int Tcl_NRCallObjProc(Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, void *clientData, size_t objc, Tcl_Obj *const objv[]); /* 589 */ EXTERN unsigned Tcl_GetFSDeviceFromStat(const Tcl_StatBuf *statPtr); /* 590 */ EXTERN unsigned Tcl_GetFSInodeFromStat(const Tcl_StatBuf *statPtr); /* 591 */ EXTERN unsigned Tcl_GetModeFromStat(const Tcl_StatBuf *statPtr); /* 592 */ |
| ︙ | ︙ | |||
1600 1601 1602 1603 1604 1605 1606 | /* 602 */ EXTERN int Tcl_SetEnsembleParameterList(Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *paramList); /* 603 */ EXTERN int Tcl_GetEnsembleParameterList(Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **paramListPtr); /* 604 */ | | | 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 | /* 602 */ EXTERN int Tcl_SetEnsembleParameterList(Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *paramList); /* 603 */ EXTERN int Tcl_GetEnsembleParameterList(Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **paramListPtr); /* 604 */ EXTERN int TclParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, int *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 605 */ EXTERN int Tcl_GetErrorLine(Tcl_Interp *interp); /* 606 */ EXTERN void Tcl_SetErrorLine(Tcl_Interp *interp, int lineNum); /* 607 */ |
| ︙ | ︙ | |||
1699 1700 1701 1702 1703 1704 1705 | EXTERN int TclZipfs_MountBuffer(Tcl_Interp *interp, const char *mountPoint, unsigned char *data, size_t datalen, int copy); /* 636 */ EXTERN void Tcl_FreeInternalRep(Tcl_Obj *objPtr); /* 637 */ EXTERN char * Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, | | | 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 | EXTERN int TclZipfs_MountBuffer(Tcl_Interp *interp, const char *mountPoint, unsigned char *data, size_t datalen, int copy); /* 636 */ EXTERN void Tcl_FreeInternalRep(Tcl_Obj *objPtr); /* 637 */ EXTERN char * Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, TCL_HASH_TYPE numBytes); /* 638 */ EXTERN Tcl_ObjInternalRep * Tcl_FetchInternalRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 639 */ EXTERN void Tcl_StoreInternalRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjInternalRep *irPtr); |
| ︙ | ︙ | |||
1765 1766 1767 1768 1769 1770 1771 | /* 659 */ EXTERN size_t Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, const char *src, size_t srcLen, int flags, Tcl_DString *dsPtr); /* 660 */ EXTERN int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber); | | > > > | > > | > > | > > > | > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 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 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 |
/* 659 */
EXTERN size_t Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding,
const char *src, size_t srcLen, int flags,
Tcl_DString *dsPtr);
/* 660 */
EXTERN int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async,
int sigNumber);
/* 661 */
EXTERN int Tcl_ListObjGetElements(Tcl_Interp *interp,
Tcl_Obj *listPtr, size_t *objcPtr,
Tcl_Obj ***objvPtr);
/* 662 */
EXTERN int Tcl_ListObjLength(Tcl_Interp *interp,
Tcl_Obj *listPtr, size_t *lengthPtr);
/* 663 */
EXTERN int Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr,
size_t *sizePtr);
/* 664 */
EXTERN int Tcl_SplitList(Tcl_Interp *interp,
const char *listStr, size_t *argcPtr,
const char ***argvPtr);
/* 665 */
EXTERN void Tcl_SplitPath(const char *path, size_t *argcPtr,
const char ***argvPtr);
/* 666 */
EXTERN Tcl_Obj * Tcl_FSSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr);
/* 667 */
EXTERN int Tcl_ParseArgsObjv(Tcl_Interp *interp,
const Tcl_ArgvInfo *argTable,
size_t *objcPtr, Tcl_Obj *const *objv,
Tcl_Obj ***remObjv);
/* 668 */
EXTERN size_t Tcl_UniCharLen(const int *uniStr);
/* 669 */
EXTERN size_t Tcl_NumUtfChars(const char *src, size_t length);
/* 670 */
EXTERN size_t Tcl_GetCharLength(Tcl_Obj *objPtr);
/* 671 */
EXTERN const char * Tcl_UtfAtIndex(const char *src, size_t index);
/* 672 */
EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, size_t first,
size_t last);
/* 673 */
EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index);
/* Slot 674 is reserved */
/* Slot 675 is reserved */
/* 676 */
EXTERN Tcl_Command Tcl_CreateObjCommand2(Tcl_Interp *interp,
const char *cmdName, Tcl_ObjCmdProc2 *proc2,
void *clientData,
Tcl_CmdDeleteProc *deleteProc);
/* 677 */
EXTERN Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, int level,
int flags, Tcl_CmdObjTraceProc2 *objProc2,
void *clientData,
Tcl_CmdObjTraceDeleteProc *delProc);
/* 678 */
EXTERN Tcl_Command Tcl_NRCreateCommand2(Tcl_Interp *interp,
const char *cmdName, Tcl_ObjCmdProc2 *proc,
Tcl_ObjCmdProc2 *nreProc2, void *clientData,
Tcl_CmdDeleteProc *deleteProc);
/* 679 */
EXTERN int Tcl_NRCallObjProc2(Tcl_Interp *interp,
Tcl_ObjCmdProc2 *objProc2, void *clientData,
size_t objc, Tcl_Obj *const objv[]);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
const struct TclIntStubs *tclIntStubs;
const struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;
typedef struct TclStubs {
int magic;
const TclStubHooks *hooks;
int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */
const char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */
TCL_NORETURN1 void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */
void * (*tcl_Alloc) (TCL_HASH_TYPE size); /* 3 */
void (*tcl_Free) (void *ptr); /* 4 */
void * (*tcl_Realloc) (void *ptr, TCL_HASH_TYPE size); /* 5 */
void * (*tcl_DbCkalloc) (TCL_HASH_TYPE size, const char *file, int line); /* 6 */
void (*tcl_DbCkfree) (void *ptr, const char *file, int line); /* 7 */
void * (*tcl_DbCkrealloc) (void *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 8 */
void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, void *clientData); /* 9 */
void (*tcl_DeleteFileHandler) (int fd); /* 10 */
void (*tcl_SetTimer) (const Tcl_Time *timePtr); /* 11 */
void (*tcl_Sleep) (int ms); /* 12 */
int (*tcl_WaitForEvent) (const Tcl_Time *timePtr); /* 13 */
int (*tcl_AppendAllObjTypes) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 14 */
void (*tcl_AppendStringsToObj) (Tcl_Obj *objPtr, ...); /* 15 */
void (*tcl_AppendToObj) (Tcl_Obj *objPtr, const char *bytes, size_t length); /* 16 */
Tcl_Obj * (*tcl_ConcatObj) (size_t objc, Tcl_Obj *const objv[]); /* 17 */
int (*tcl_ConvertToType) (Tcl_Interp *interp, Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 18 */
void (*tcl_DbDecrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 19 */
void (*tcl_DbIncrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 20 */
int (*tcl_DbIsShared) (Tcl_Obj *objPtr, const char *file, int line); /* 21 */
void (*reserved22)(void);
Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, size_t numBytes, const char *file, int line); /* 23 */
Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */
Tcl_Obj * (*tcl_DbNewListObj) (size_t objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */
void (*reserved26)(void);
Tcl_Obj * (*tcl_DbNewObj) (const char *file, int line); /* 27 */
Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, size_t length, const char *file, int line); /* 28 */
Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */
void (*tclFreeObj) (Tcl_Obj *objPtr); /* 30 */
int (*tcl_GetBoolean) (Tcl_Interp *interp, const char *src, int *intPtr); /* 31 */
int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 32 */
unsigned char * (*tclGetByteArrayFromObj) (Tcl_Obj *objPtr, int *numBytesPtr); /* 33 */
int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */
int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */
void (*reserved36)(void);
int (*tcl_GetInt) (Tcl_Interp *interp, const char *src, int *intPtr); /* 37 */
int (*tcl_GetIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 38 */
int (*tcl_GetLongFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 39 */
const Tcl_ObjType * (*tcl_GetObjType) (const char *typeName); /* 40 */
char * (*tclGetStringFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 41 */
void (*tcl_InvalidateStringRep) (Tcl_Obj *objPtr); /* 42 */
int (*tcl_ListObjAppendList) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *elemListPtr); /* 43 */
int (*tcl_ListObjAppendElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *objPtr); /* 44 */
int (*tclListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *objcPtr, Tcl_Obj ***objvPtr); /* 45 */
int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t index, Tcl_Obj **objPtrPtr); /* 46 */
int (*tclListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */
int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t first, size_t count, size_t objc, Tcl_Obj *const objv[]); /* 48 */
void (*reserved49)(void);
Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, size_t numBytes); /* 50 */
Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */
void (*reserved52)(void);
Tcl_Obj * (*tcl_NewListObj) (size_t objc, Tcl_Obj *const objv[]); /* 53 */
void (*reserved54)(void);
Tcl_Obj * (*tcl_NewObj) (void); /* 55 */
Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, size_t length); /* 56 */
void (*reserved57)(void);
unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, size_t numBytes); /* 58 */
void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, size_t numBytes); /* 59 */
void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */
void (*reserved61)(void);
void (*tcl_SetListObj) (Tcl_Obj *objPtr, size_t objc, Tcl_Obj *const objv[]); /* 62 */
void (*reserved63)(void);
void (*tcl_SetObjLength) (Tcl_Obj *objPtr, size_t length); /* 64 */
void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, size_t length); /* 65 */
void (*reserved66)(void);
void (*reserved67)(void);
void (*tcl_AllowExceptions) (Tcl_Interp *interp); /* 68 */
void (*tcl_AppendElement) (Tcl_Interp *interp, const char *element); /* 69 */
void (*tcl_AppendResult) (Tcl_Interp *interp, ...); /* 70 */
Tcl_AsyncHandler (*tcl_AsyncCreate) (Tcl_AsyncProc *proc, void *clientData); /* 71 */
void (*tcl_AsyncDelete) (Tcl_AsyncHandler async); /* 72 */
int (*tcl_AsyncInvoke) (Tcl_Interp *interp, int code); /* 73 */
void (*tcl_AsyncMark) (Tcl_AsyncHandler async); /* 74 */
int (*tcl_AsyncReady) (void); /* 75 */
void (*reserved76)(void);
void (*reserved77)(void);
int (*tcl_BadChannelOption) (Tcl_Interp *interp, const char *optionName, const char *optionList); /* 78 */
void (*tcl_CallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *clientData); /* 79 */
void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, void *clientData); /* 80 */
int (*tcl_Close) (Tcl_Interp *interp, Tcl_Channel chan); /* 81 */
int (*tcl_CommandComplete) (const char *cmd); /* 82 */
char * (*tcl_Concat) (size_t argc, const char *const *argv); /* 83 */
size_t (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */
size_t (*tcl_ConvertCountedElement) (const char *src, size_t length, char *dst, int flags); /* 85 */
int (*tcl_CreateAlias) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, size_t argc, const char *const *argv); /* 86 */
int (*tcl_CreateAliasObj) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, size_t objc, Tcl_Obj *const objv[]); /* 87 */
Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, void *instanceData, int mask); /* 88 */
void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, void *clientData); /* 89 */
void (*tcl_CreateCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, void *clientData); /* 90 */
Tcl_Command (*tcl_CreateCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 91 */
void (*tcl_CreateEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, void *clientData); /* 92 */
void (*tcl_CreateExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 93 */
Tcl_Interp * (*tcl_CreateInterp) (void); /* 94 */
|
| ︙ | ︙ | |||
1907 1908 1909 1910 1911 1912 1913 |
int (*tcl_DeleteCommandFromToken) (Tcl_Interp *interp, Tcl_Command command); /* 104 */
void (*tcl_DeleteEvents) (Tcl_EventDeleteProc *proc, void *clientData); /* 105 */
void (*tcl_DeleteEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, void *clientData); /* 106 */
void (*tcl_DeleteExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 107 */
void (*tcl_DeleteHashEntry) (Tcl_HashEntry *entryPtr); /* 108 */
void (*tcl_DeleteHashTable) (Tcl_HashTable *tablePtr); /* 109 */
void (*tcl_DeleteInterp) (Tcl_Interp *interp); /* 110 */
| | | 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 |
int (*tcl_DeleteCommandFromToken) (Tcl_Interp *interp, Tcl_Command command); /* 104 */
void (*tcl_DeleteEvents) (Tcl_EventDeleteProc *proc, void *clientData); /* 105 */
void (*tcl_DeleteEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, void *clientData); /* 106 */
void (*tcl_DeleteExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 107 */
void (*tcl_DeleteHashEntry) (Tcl_HashEntry *entryPtr); /* 108 */
void (*tcl_DeleteHashTable) (Tcl_HashTable *tablePtr); /* 109 */
void (*tcl_DeleteInterp) (Tcl_Interp *interp); /* 110 */
void (*tcl_DetachPids) (size_t numPids, Tcl_Pid *pidPtr); /* 111 */
void (*tcl_DeleteTimerHandler) (Tcl_TimerToken token); /* 112 */
void (*tcl_DeleteTrace) (Tcl_Interp *interp, Tcl_Trace trace); /* 113 */
void (*tcl_DontCallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *clientData); /* 114 */
int (*tcl_DoOneEvent) (int flags); /* 115 */
void (*tcl_DoWhenIdle) (Tcl_IdleProc *proc, void *clientData); /* 116 */
char * (*tcl_DStringAppend) (Tcl_DString *dsPtr, const char *bytes, ssize_t length); /* 117 */
char * (*tcl_DStringAppendElement) (Tcl_DString *dsPtr, const char *element); /* 118 */
|
| ︙ | ︙ | |||
1948 1949 1950 1951 1952 1953 1954 |
Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */
int (*tcl_Flush) (Tcl_Channel chan); /* 146 */
void (*reserved147)(void);
int (*tcl_GetAlias) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */
int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */
void * (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */
Tcl_Channel (*tcl_GetChannel) (Tcl_Interp *interp, const char *chanName, int *modePtr); /* 151 */
| | | 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 |
Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */
int (*tcl_Flush) (Tcl_Channel chan); /* 146 */
void (*reserved147)(void);
int (*tcl_GetAlias) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */
int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */
void * (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */
Tcl_Channel (*tcl_GetChannel) (Tcl_Interp *interp, const char *chanName, int *modePtr); /* 151 */
size_t (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */
int (*tcl_GetChannelHandle) (Tcl_Channel chan, int direction, void **handlePtr); /* 153 */
void * (*tcl_GetChannelInstanceData) (Tcl_Channel chan); /* 154 */
int (*tcl_GetChannelMode) (Tcl_Channel chan); /* 155 */
const char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */
int (*tcl_GetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr); /* 157 */
const Tcl_ChannelType * (*tcl_GetChannelType) (Tcl_Channel chan); /* 158 */
int (*tcl_GetCommandInfo) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); /* 159 */
|
| ︙ | ︙ | |||
1982 1983 1984 1985 1986 1987 1988 |
int (*tcl_HideCommand) (Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken); /* 179 */
int (*tcl_Init) (Tcl_Interp *interp); /* 180 */
void (*tcl_InitHashTable) (Tcl_HashTable *tablePtr, int keyType); /* 181 */
int (*tcl_InputBlocked) (Tcl_Channel chan); /* 182 */
int (*tcl_InputBuffered) (Tcl_Channel chan); /* 183 */
int (*tcl_InterpDeleted) (Tcl_Interp *interp); /* 184 */
int (*tcl_IsSafe) (Tcl_Interp *interp); /* 185 */
| | | | | | | | | | | 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 |
int (*tcl_HideCommand) (Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken); /* 179 */
int (*tcl_Init) (Tcl_Interp *interp); /* 180 */
void (*tcl_InitHashTable) (Tcl_HashTable *tablePtr, int keyType); /* 181 */
int (*tcl_InputBlocked) (Tcl_Channel chan); /* 182 */
int (*tcl_InputBuffered) (Tcl_Channel chan); /* 183 */
int (*tcl_InterpDeleted) (Tcl_Interp *interp); /* 184 */
int (*tcl_IsSafe) (Tcl_Interp *interp); /* 185 */
char * (*tcl_JoinPath) (size_t argc, const char *const *argv, Tcl_DString *resultPtr); /* 186 */
int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, void *addr, int type); /* 187 */
void (*reserved188)(void);
Tcl_Channel (*tcl_MakeFileChannel) (void *handle, int mode); /* 189 */
int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */
Tcl_Channel (*tcl_MakeTcpClientChannel) (void *tcpSocket); /* 191 */
char * (*tcl_Merge) (size_t argc, const char *const *argv); /* 192 */
Tcl_HashEntry * (*tcl_NextHashEntry) (Tcl_HashSearch *searchPtr); /* 193 */
void (*tcl_NotifyChannel) (Tcl_Channel channel, int mask); /* 194 */
Tcl_Obj * (*tcl_ObjGetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 195 */
Tcl_Obj * (*tcl_ObjSetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 196 */
Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, size_t argc, const char **argv, int flags); /* 197 */
Tcl_Channel (*tcl_OpenFileChannel) (Tcl_Interp *interp, const char *fileName, const char *modeString, int permissions); /* 198 */
Tcl_Channel (*tcl_OpenTcpClient) (Tcl_Interp *interp, int port, const char *address, const char *myaddr, int myport, int async); /* 199 */
Tcl_Channel (*tcl_OpenTcpServer) (Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, void *callbackData); /* 200 */
void (*tcl_Preserve) (void *data); /* 201 */
void (*tcl_PrintDouble) (Tcl_Interp *interp, double value, char *dst); /* 202 */
int (*tcl_PutEnv) (const char *assignment); /* 203 */
const char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */
void (*tcl_QueueEvent) (Tcl_Event *evPtr, int position); /* 205 */
size_t (*tcl_Read) (Tcl_Channel chan, char *bufPtr, size_t toRead); /* 206 */
void (*tcl_ReapDetachedProcs) (void); /* 207 */
int (*tcl_RecordAndEval) (Tcl_Interp *interp, const char *cmd, int flags); /* 208 */
int (*tcl_RecordAndEvalObj) (Tcl_Interp *interp, Tcl_Obj *cmdPtr, int flags); /* 209 */
void (*tcl_RegisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 210 */
void (*tcl_RegisterObjType) (const Tcl_ObjType *typePtr); /* 211 */
Tcl_RegExp (*tcl_RegExpCompile) (Tcl_Interp *interp, const char *pattern); /* 212 */
int (*tcl_RegExpExec) (Tcl_Interp *interp, Tcl_RegExp regexp, const char *text, const char *start); /* 213 */
int (*tcl_RegExpMatch) (Tcl_Interp *interp, const char *text, const char *pattern); /* 214 */
void (*tcl_RegExpRange) (Tcl_RegExp regexp, size_t index, const char **startPtr, const char **endPtr); /* 215 */
void (*tcl_Release) (void *clientData); /* 216 */
void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */
size_t (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */
size_t (*tcl_ScanCountedElement) (const char *src, size_t length, int *flagPtr); /* 219 */
void (*reserved220)(void);
int (*tcl_ServiceAll) (void); /* 221 */
int (*tcl_ServiceEvent) (int flags); /* 222 */
void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, void *clientData); /* 223 */
void (*tcl_SetChannelBufferSize) (Tcl_Channel chan, size_t sz); /* 224 */
int (*tcl_SetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, const char *newValue); /* 225 */
int (*tcl_SetCommandInfo) (Tcl_Interp *interp, const char *cmdName, const Tcl_CmdInfo *infoPtr); /* 226 */
void (*tcl_SetErrno) (int err); /* 227 */
void (*tcl_SetErrorCode) (Tcl_Interp *interp, ...); /* 228 */
void (*tcl_SetMaxBlockTime) (const Tcl_Time *timePtr); /* 229 */
void (*reserved230)(void);
size_t (*tcl_SetRecursionLimit) (Tcl_Interp *interp, size_t depth); /* 231 */
void (*reserved232)(void);
int (*tcl_SetServiceMode) (int mode); /* 233 */
void (*tcl_SetObjErrorCode) (Tcl_Interp *interp, Tcl_Obj *errorObjPtr); /* 234 */
void (*tcl_SetObjResult) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr); /* 235 */
void (*tcl_SetStdChannel) (Tcl_Channel channel, int type); /* 236 */
void (*reserved237)(void);
const char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */
const char * (*tcl_SignalId) (int sig); /* 239 */
const char * (*tcl_SignalMsg) (int sig); /* 240 */
void (*tcl_SourceRCFile) (Tcl_Interp *interp); /* 241 */
int (*tclSplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, const char ***argvPtr); /* 242 */
void (*tclSplitPath) (const char *path, int *argcPtr, const char ***argvPtr); /* 243 */
void (*reserved244)(void);
void (*reserved245)(void);
void (*reserved246)(void);
void (*reserved247)(void);
int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 248 */
char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */
ssize_t (*tcl_Ungets) (Tcl_Channel chan, const char *str, ssize_t len, int atHead); /* 250 */
void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */
int (*tcl_UnregisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 252 */
void (*reserved253)(void);
int (*tcl_UnsetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 254 */
void (*reserved255)(void);
void (*tcl_UntraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 256 */
void (*tcl_UpdateLinkedVar) (Tcl_Interp *interp, const char *varName); /* 257 */
void (*reserved258)(void);
int (*tcl_UpVar2) (Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags); /* 259 */
int (*tcl_VarEval) (Tcl_Interp *interp, ...); /* 260 */
void (*reserved261)(void);
void * (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, void *prevClientData); /* 262 */
ssize_t (*tcl_Write) (Tcl_Channel chan, const char *s, ssize_t slen); /* 263 */
void (*tcl_WrongNumArgs) (Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], const char *message); /* 264 */
int (*tcl_DumpActiveMemory) (const char *fileName); /* 265 */
void (*tcl_ValidateAllMemory) (const char *file, int line); /* 266 */
void (*reserved267)(void);
void (*reserved268)(void);
char * (*tcl_HashStats) (Tcl_HashTable *tablePtr); /* 269 */
const char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, const char **termPtr); /* 270 */
void (*reserved271)(void);
|
| ︙ | ︙ | |||
2088 2089 2090 2091 2092 2093 2094 |
void (*reserved285)(void);
void (*tcl_AppendObjToObj) (Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr); /* 286 */
Tcl_Encoding (*tcl_CreateEncoding) (const Tcl_EncodingType *typePtr); /* 287 */
void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 288 */
void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 289 */
void (*reserved290)(void);
int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, size_t numBytes, int flags); /* 291 */
| | | 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 |
void (*reserved285)(void);
void (*tcl_AppendObjToObj) (Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr); /* 286 */
Tcl_Encoding (*tcl_CreateEncoding) (const Tcl_EncodingType *typePtr); /* 287 */
void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 288 */
void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 289 */
void (*reserved290)(void);
int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, size_t numBytes, int flags); /* 291 */
int (*tcl_EvalObjv) (Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int flags); /* 292 */
int (*tcl_EvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 293 */
TCL_NORETURN1 void (*tcl_ExitThread) (int status); /* 294 */
int (*tcl_ExternalToUtf) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, ssize_t srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, size_t dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 295 */
char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, const char *src, ssize_t srcLen, Tcl_DString *dsPtr); /* 296 */
void (*tcl_FinalizeThread) (void); /* 297 */
void (*tcl_FinalizeNotifier) (void *clientData); /* 298 */
void (*tcl_FreeEncoding) (Tcl_Encoding encoding); /* 299 */
|
| ︙ | ︙ | |||
2115 2116 2117 2118 2119 2120 2121 |
size_t (*tclNumUtfChars) (const char *src, ssize_t length); /* 312 */
ssize_t (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, ssize_t charsToRead, int appendFlag); /* 313 */
void (*reserved314)(void);
void (*reserved315)(void);
int (*tcl_SetSystemEncoding) (Tcl_Interp *interp, const char *name); /* 316 */
Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */
void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */
| | | 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 |
size_t (*tclNumUtfChars) (const char *src, ssize_t length); /* 312 */
ssize_t (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, ssize_t charsToRead, int appendFlag); /* 313 */
void (*reserved314)(void);
void (*reserved315)(void);
int (*tcl_SetSystemEncoding) (Tcl_Interp *interp, const char *name); /* 316 */
Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */
void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */
void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, int position); /* 319 */
int (*tcl_UniCharAtIndex) (const char *src, ssize_t index); /* 320 */
int (*tcl_UniCharToLower) (int ch); /* 321 */
int (*tcl_UniCharToTitle) (int ch); /* 322 */
int (*tcl_UniCharToUpper) (int ch); /* 323 */
int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */
const char * (*tclUtfAtIndex) (const char *src, ssize_t index); /* 325 */
int (*tclUtfCharComplete) (const char *src, size_t length); /* 326 */
|
| ︙ | ︙ | |||
2186 2187 2188 2189 2190 2191 2192 |
Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, size_t first, size_t last); /* 383 */
void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t length); /* 384 */
int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */
void (*tcl_SetNotifier) (const Tcl_NotifierProcs *notifierProcPtr); /* 386 */
Tcl_Mutex * (*tcl_GetAllocMutex) (void); /* 387 */
int (*tcl_GetChannelNames) (Tcl_Interp *interp); /* 388 */
int (*tcl_GetChannelNamesEx) (Tcl_Interp *interp, const char *pattern); /* 389 */
| | | 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 |
Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, size_t first, size_t last); /* 383 */
void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t length); /* 384 */
int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */
void (*tcl_SetNotifier) (const Tcl_NotifierProcs *notifierProcPtr); /* 386 */
Tcl_Mutex * (*tcl_GetAllocMutex) (void); /* 387 */
int (*tcl_GetChannelNames) (Tcl_Interp *interp); /* 388 */
int (*tcl_GetChannelNamesEx) (Tcl_Interp *interp, const char *pattern); /* 389 */
int (*tcl_ProcObjCmd) (void *clientData, Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[]); /* 390 */
void (*tcl_ConditionFinalize) (Tcl_Condition *condPtr); /* 391 */
void (*tcl_MutexFinalize) (Tcl_Mutex *mutex); /* 392 */
int (*tcl_CreateThread) (Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, size_t stackSize, int flags); /* 393 */
ssize_t (*tcl_ReadRaw) (Tcl_Channel chan, char *dst, size_t bytesToRead); /* 394 */
ssize_t (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, ssize_t srcLen); /* 395 */
Tcl_Channel (*tcl_GetTopChannel) (Tcl_Channel chan); /* 396 */
int (*tcl_ChannelBuffered) (Tcl_Channel chan); /* 397 */
|
| ︙ | ︙ | |||
2224 2225 2226 2227 2228 2229 2230 |
void (*reserved421)(void);
void (*reserved422)(void);
void (*tcl_InitCustomHashTable) (Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr); /* 423 */
void (*tcl_InitObjHashTable) (Tcl_HashTable *tablePtr); /* 424 */
void * (*tcl_CommandTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, void *prevClientData); /* 425 */
int (*tcl_TraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 426 */
void (*tcl_UntraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 427 */
| | | | | | 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 |
void (*reserved421)(void);
void (*reserved422)(void);
void (*tcl_InitCustomHashTable) (Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr); /* 423 */
void (*tcl_InitObjHashTable) (Tcl_HashTable *tablePtr); /* 424 */
void * (*tcl_CommandTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, void *prevClientData); /* 425 */
int (*tcl_TraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 426 */
void (*tcl_UntraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 427 */
void * (*tcl_AttemptAlloc) (TCL_HASH_TYPE size); /* 428 */
void * (*tcl_AttemptDbCkalloc) (TCL_HASH_TYPE size, const char *file, int line); /* 429 */
void * (*tcl_AttemptRealloc) (void *ptr, TCL_HASH_TYPE size); /* 430 */
void * (*tcl_AttemptDbCkrealloc) (void *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 431 */
int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, size_t length); /* 432 */
Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */
Tcl_UniChar * (*tclGetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */
void (*reserved435)(void);
void (*reserved436)(void);
Tcl_Obj * (*tcl_SubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 437 */
int (*tcl_DetachChannel) (Tcl_Interp *interp, Tcl_Channel channel); /* 438 */
|
| ︙ | ︙ | |||
2256 2257 2258 2259 2260 2261 2262 |
const char *const * (*tcl_FSFileAttrStrings) (Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 453 */
int (*tcl_FSStat) (Tcl_Obj *pathPtr, Tcl_StatBuf *buf); /* 454 */
int (*tcl_FSAccess) (Tcl_Obj *pathPtr, int mode); /* 455 */
Tcl_Channel (*tcl_FSOpenFileChannel) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *modeString, int permissions); /* 456 */
Tcl_Obj * (*tcl_FSGetCwd) (Tcl_Interp *interp); /* 457 */
int (*tcl_FSChdir) (Tcl_Obj *pathPtr); /* 458 */
int (*tcl_FSConvertToPathType) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 459 */
| | | | | 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 |
const char *const * (*tcl_FSFileAttrStrings) (Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 453 */
int (*tcl_FSStat) (Tcl_Obj *pathPtr, Tcl_StatBuf *buf); /* 454 */
int (*tcl_FSAccess) (Tcl_Obj *pathPtr, int mode); /* 455 */
Tcl_Channel (*tcl_FSOpenFileChannel) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *modeString, int permissions); /* 456 */
Tcl_Obj * (*tcl_FSGetCwd) (Tcl_Interp *interp); /* 457 */
int (*tcl_FSChdir) (Tcl_Obj *pathPtr); /* 458 */
int (*tcl_FSConvertToPathType) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 459 */
Tcl_Obj * (*tcl_FSJoinPath) (Tcl_Obj *listObj, size_t elements); /* 460 */
Tcl_Obj * (*tclFSSplitPath) (Tcl_Obj *pathPtr, int *lenPtr); /* 461 */
int (*tcl_FSEqualPaths) (Tcl_Obj *firstPtr, Tcl_Obj *secondPtr); /* 462 */
Tcl_Obj * (*tcl_FSGetNormalizedPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 463 */
Tcl_Obj * (*tcl_FSJoinToPath) (Tcl_Obj *pathPtr, size_t objc, Tcl_Obj *const objv[]); /* 464 */
void * (*tcl_FSGetInternalRep) (Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr); /* 465 */
Tcl_Obj * (*tcl_FSGetTranslatedPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 466 */
int (*tcl_FSEvalFile) (Tcl_Interp *interp, Tcl_Obj *fileName); /* 467 */
Tcl_Obj * (*tcl_FSNewNativePath) (const Tcl_Filesystem *fromFilesystem, void *clientData); /* 468 */
const void * (*tcl_FSGetNativePath) (Tcl_Obj *pathPtr); /* 469 */
Tcl_Obj * (*tcl_FSFileSystemInfo) (Tcl_Obj *pathPtr); /* 470 */
Tcl_Obj * (*tcl_FSPathSeparator) (Tcl_Obj *pathPtr); /* 471 */
|
| ︙ | ︙ | |||
2293 2294 2295 2296 2297 2298 2299 |
Tcl_StatBuf * (*tcl_AllocStatBuf) (void); /* 490 */
off_t (*tcl_Seek) (Tcl_Channel chan, long long offset, int mode); /* 491 */
long long (*tcl_Tell) (Tcl_Channel chan); /* 492 */
Tcl_DriverWideSeekProc * (*tcl_ChannelWideSeekProc) (const Tcl_ChannelType *chanTypePtr); /* 493 */
int (*tcl_DictObjPut) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr, Tcl_Obj *valuePtr); /* 494 */
int (*tcl_DictObjGet) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr, Tcl_Obj **valuePtrPtr); /* 495 */
int (*tcl_DictObjRemove) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr); /* 496 */
| | | | | 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 |
Tcl_StatBuf * (*tcl_AllocStatBuf) (void); /* 490 */
off_t (*tcl_Seek) (Tcl_Channel chan, long long offset, int mode); /* 491 */
long long (*tcl_Tell) (Tcl_Channel chan); /* 492 */
Tcl_DriverWideSeekProc * (*tcl_ChannelWideSeekProc) (const Tcl_ChannelType *chanTypePtr); /* 493 */
int (*tcl_DictObjPut) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr, Tcl_Obj *valuePtr); /* 494 */
int (*tcl_DictObjGet) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr, Tcl_Obj **valuePtrPtr); /* 495 */
int (*tcl_DictObjRemove) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr); /* 496 */
int (*tclDictObjSize) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int *sizePtr); /* 497 */
int (*tcl_DictObjFirst) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); /* 498 */
void (*tcl_DictObjNext) (Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); /* 499 */
void (*tcl_DictObjDone) (Tcl_DictSearch *searchPtr); /* 500 */
int (*tcl_DictObjPutKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr); /* 501 */
int (*tcl_DictObjRemoveKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t keyc, Tcl_Obj *const *keyv); /* 502 */
Tcl_Obj * (*tcl_NewDictObj) (void); /* 503 */
Tcl_Obj * (*tcl_DbNewDictObj) (const char *file, int line); /* 504 */
void (*tcl_RegisterConfig) (Tcl_Interp *interp, const char *pkgName, const Tcl_Config *configuration, const char *valEncoding); /* 505 */
Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, void *clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 506 */
void (*tcl_DeleteNamespace) (Tcl_Namespace *nsPtr); /* 507 */
int (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 508 */
int (*tcl_Export) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 509 */
|
| ︙ | ︙ | |||
2321 2322 2323 2324 2325 2326 2327 |
int (*tcl_FSEvalFileEx) (Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); /* 518 */
void (*reserved519)(void);
void (*tcl_LimitAddHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, void *clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 520 */
void (*tcl_LimitRemoveHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, void *clientData); /* 521 */
int (*tcl_LimitReady) (Tcl_Interp *interp); /* 522 */
int (*tcl_LimitCheck) (Tcl_Interp *interp); /* 523 */
int (*tcl_LimitExceeded) (Tcl_Interp *interp); /* 524 */
| | | 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 |
int (*tcl_FSEvalFileEx) (Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); /* 518 */
void (*reserved519)(void);
void (*tcl_LimitAddHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, void *clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 520 */
void (*tcl_LimitRemoveHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, void *clientData); /* 521 */
int (*tcl_LimitReady) (Tcl_Interp *interp); /* 522 */
int (*tcl_LimitCheck) (Tcl_Interp *interp); /* 523 */
int (*tcl_LimitExceeded) (Tcl_Interp *interp); /* 524 */
void (*tcl_LimitSetCommands) (Tcl_Interp *interp, size_t commandLimit); /* 525 */
void (*tcl_LimitSetTime) (Tcl_Interp *interp, Tcl_Time *timeLimitPtr); /* 526 */
void (*tcl_LimitSetGranularity) (Tcl_Interp *interp, int type, int granularity); /* 527 */
int (*tcl_LimitTypeEnabled) (Tcl_Interp *interp, int type); /* 528 */
int (*tcl_LimitTypeExceeded) (Tcl_Interp *interp, int type); /* 529 */
void (*tcl_LimitTypeSet) (Tcl_Interp *interp, int type); /* 530 */
void (*tcl_LimitTypeReset) (Tcl_Interp *interp, int type); /* 531 */
int (*tcl_LimitGetCommands) (Tcl_Interp *interp); /* 532 */
|
| ︙ | ︙ | |||
2369 2370 2371 2372 2373 2374 2375 |
int (*tcl_InitBignumFromDouble) (Tcl_Interp *interp, double initval, void *toInit); /* 566 */
Tcl_Obj * (*tcl_GetNamespaceUnknownHandler) (Tcl_Interp *interp, Tcl_Namespace *nsPtr); /* 567 */
int (*tcl_SetNamespaceUnknownHandler) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *handlerPtr); /* 568 */
int (*tcl_GetEncodingFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr); /* 569 */
Tcl_Obj * (*tcl_GetEncodingSearchPath) (void); /* 570 */
int (*tcl_SetEncodingSearchPath) (Tcl_Obj *searchPath); /* 571 */
const char * (*tcl_GetEncodingNameFromEnvironment) (Tcl_DString *bufPtr); /* 572 */
| | | | | | | | | 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 |
int (*tcl_InitBignumFromDouble) (Tcl_Interp *interp, double initval, void *toInit); /* 566 */
Tcl_Obj * (*tcl_GetNamespaceUnknownHandler) (Tcl_Interp *interp, Tcl_Namespace *nsPtr); /* 567 */
int (*tcl_SetNamespaceUnknownHandler) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *handlerPtr); /* 568 */
int (*tcl_GetEncodingFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr); /* 569 */
Tcl_Obj * (*tcl_GetEncodingSearchPath) (void); /* 570 */
int (*tcl_SetEncodingSearchPath) (Tcl_Obj *searchPath); /* 571 */
const char * (*tcl_GetEncodingNameFromEnvironment) (Tcl_DString *bufPtr); /* 572 */
int (*tcl_PkgRequireProc) (Tcl_Interp *interp, const char *name, size_t objc, Tcl_Obj *const objv[], void *clientDataPtr); /* 573 */
void (*tcl_AppendObjToErrorInfo) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 574 */
void (*tcl_AppendLimitedToObj) (Tcl_Obj *objPtr, const char *bytes, size_t length, size_t limit, const char *ellipsis); /* 575 */
Tcl_Obj * (*tcl_Format) (Tcl_Interp *interp, const char *format, size_t objc, Tcl_Obj *const objv[]); /* 576 */
int (*tcl_AppendFormatToObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, size_t objc, Tcl_Obj *const objv[]); /* 577 */
Tcl_Obj * (*tcl_ObjPrintf) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 578 */
void (*tcl_AppendPrintfToObj) (Tcl_Obj *objPtr, const char *format, ...) TCL_FORMAT_PRINTF(2, 3); /* 579 */
int (*tcl_CancelEval) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr, void *clientData, int flags); /* 580 */
int (*tcl_Canceled) (Tcl_Interp *interp, int flags); /* 581 */
int (*tcl_CreatePipe) (Tcl_Interp *interp, Tcl_Channel *rchan, Tcl_Channel *wchan, int flags); /* 582 */
Tcl_Command (*tcl_NRCreateCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 583 */
int (*tcl_NREvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 584 */
int (*tcl_NREvalObjv) (Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int flags); /* 585 */
int (*tcl_NRCmdSwap) (Tcl_Interp *interp, Tcl_Command cmd, size_t objc, Tcl_Obj *const objv[], int flags); /* 586 */
void (*tcl_NRAddCallback) (Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr, void *data0, void *data1, void *data2, void *data3); /* 587 */
int (*tcl_NRCallObjProc) (Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, void *clientData, size_t objc, Tcl_Obj *const objv[]); /* 588 */
unsigned (*tcl_GetFSDeviceFromStat) (const Tcl_StatBuf *statPtr); /* 589 */
unsigned (*tcl_GetFSInodeFromStat) (const Tcl_StatBuf *statPtr); /* 590 */
unsigned (*tcl_GetModeFromStat) (const Tcl_StatBuf *statPtr); /* 591 */
int (*tcl_GetLinkCountFromStat) (const Tcl_StatBuf *statPtr); /* 592 */
int (*tcl_GetUserIdFromStat) (const Tcl_StatBuf *statPtr); /* 593 */
int (*tcl_GetGroupIdFromStat) (const Tcl_StatBuf *statPtr); /* 594 */
int (*tcl_GetDeviceTypeFromStat) (const Tcl_StatBuf *statPtr); /* 595 */
long long (*tcl_GetAccessTimeFromStat) (const Tcl_StatBuf *statPtr); /* 596 */
long long (*tcl_GetModificationTimeFromStat) (const Tcl_StatBuf *statPtr); /* 597 */
long long (*tcl_GetChangeTimeFromStat) (const Tcl_StatBuf *statPtr); /* 598 */
unsigned long long (*tcl_GetSizeFromStat) (const Tcl_StatBuf *statPtr); /* 599 */
unsigned long long (*tcl_GetBlocksFromStat) (const Tcl_StatBuf *statPtr); /* 600 */
unsigned (*tcl_GetBlockSizeFromStat) (const Tcl_StatBuf *statPtr); /* 601 */
int (*tcl_SetEnsembleParameterList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *paramList); /* 602 */
int (*tcl_GetEnsembleParameterList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **paramListPtr); /* 603 */
int (*tclParseArgsObjv) (Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, int *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 604 */
int (*tcl_GetErrorLine) (Tcl_Interp *interp); /* 605 */
void (*tcl_SetErrorLine) (Tcl_Interp *interp, int lineNum); /* 606 */
void (*tcl_TransferResult) (Tcl_Interp *sourceInterp, int code, Tcl_Interp *targetInterp); /* 607 */
int (*tcl_InterpActive) (Tcl_Interp *interp); /* 608 */
void (*tcl_BackgroundException) (Tcl_Interp *interp, int code); /* 609 */
int (*tcl_ZlibDeflate) (Tcl_Interp *interp, int format, Tcl_Obj *data, int level, Tcl_Obj *gzipHeaderDictObj); /* 610 */
int (*tcl_ZlibInflate) (Tcl_Interp *interp, int format, Tcl_Obj *data, size_t buffersize, Tcl_Obj *gzipHeaderDictObj); /* 611 */
|
| ︙ | ︙ | |||
2433 2434 2435 2436 2437 2438 2439 |
void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */
Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, void *callbackData); /* 631 */
int (*tclZipfs_Mount) (Tcl_Interp *interp, const char *mountPoint, const char *zipname, const char *passwd); /* 632 */
int (*tclZipfs_Unmount) (Tcl_Interp *interp, const char *mountPoint); /* 633 */
Tcl_Obj * (*tclZipfs_TclLibrary) (void); /* 634 */
int (*tclZipfs_MountBuffer) (Tcl_Interp *interp, const char *mountPoint, unsigned char *data, size_t datalen, int copy); /* 635 */
void (*tcl_FreeInternalRep) (Tcl_Obj *objPtr); /* 636 */
| | | 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 |
void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */
Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, void *callbackData); /* 631 */
int (*tclZipfs_Mount) (Tcl_Interp *interp, const char *mountPoint, const char *zipname, const char *passwd); /* 632 */
int (*tclZipfs_Unmount) (Tcl_Interp *interp, const char *mountPoint); /* 633 */
Tcl_Obj * (*tclZipfs_TclLibrary) (void); /* 634 */
int (*tclZipfs_MountBuffer) (Tcl_Interp *interp, const char *mountPoint, unsigned char *data, size_t datalen, int copy); /* 635 */
void (*tcl_FreeInternalRep) (Tcl_Obj *objPtr); /* 636 */
char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, TCL_HASH_TYPE numBytes); /* 637 */
Tcl_ObjInternalRep * (*tcl_FetchInternalRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 638 */
void (*tcl_StoreInternalRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjInternalRep *irPtr); /* 639 */
int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 640 */
void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */
void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */
int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */
int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, size_t size); /* 644 */
|
| ︙ | ︙ | |||
2457 2458 2459 2460 2461 2462 2463 |
int (*tcl_UtfCharComplete) (const char *src, size_t length); /* 654 */
const char * (*tcl_UtfNext) (const char *src); /* 655 */
const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */
int (*tcl_UniCharIsUnicode) (int ch); /* 657 */
size_t (*tcl_ExternalToUtfDStringEx) (Tcl_Encoding encoding, const char *src, size_t srcLen, int flags, Tcl_DString *dsPtr); /* 658 */
size_t (*tcl_UtfToExternalDStringEx) (Tcl_Encoding encoding, const char *src, size_t srcLen, int flags, Tcl_DString *dsPtr); /* 659 */
int (*tcl_AsyncMarkFromSignal) (Tcl_AsyncHandler async, int sigNumber); /* 660 */
| | | | | | | | > > > > > > | 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 |
int (*tcl_UtfCharComplete) (const char *src, size_t length); /* 654 */
const char * (*tcl_UtfNext) (const char *src); /* 655 */
const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */
int (*tcl_UniCharIsUnicode) (int ch); /* 657 */
size_t (*tcl_ExternalToUtfDStringEx) (Tcl_Encoding encoding, const char *src, size_t srcLen, int flags, Tcl_DString *dsPtr); /* 658 */
size_t (*tcl_UtfToExternalDStringEx) (Tcl_Encoding encoding, const char *src, size_t srcLen, int flags, Tcl_DString *dsPtr); /* 659 */
int (*tcl_AsyncMarkFromSignal) (Tcl_AsyncHandler async, int sigNumber); /* 660 */
int (*tcl_ListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *objcPtr, Tcl_Obj ***objvPtr); /* 661 */
int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *lengthPtr); /* 662 */
int (*tcl_DictObjSize) (Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t *sizePtr); /* 663 */
int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, size_t *argcPtr, const char ***argvPtr); /* 664 */
void (*tcl_SplitPath) (const char *path, size_t *argcPtr, const char ***argvPtr); /* 665 */
Tcl_Obj * (*tcl_FSSplitPath) (Tcl_Obj *pathPtr, size_t *lenPtr); /* 666 */
int (*tcl_ParseArgsObjv) (Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, size_t *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 667 */
size_t (*tcl_UniCharLen) (const int *uniStr); /* 668 */
size_t (*tcl_NumUtfChars) (const char *src, size_t length); /* 669 */
size_t (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 670 */
const char * (*tcl_UtfAtIndex) (const char *src, size_t index); /* 671 */
Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, size_t first, size_t last); /* 672 */
int (*tcl_GetUniChar) (Tcl_Obj *objPtr, size_t index); /* 673 */
void (*reserved674)(void);
void (*reserved675)(void);
Tcl_Command (*tcl_CreateObjCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 676 */
Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */
Tcl_Command (*tcl_NRCreateCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc, Tcl_ObjCmdProc2 *nreProc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 678 */
int (*tcl_NRCallObjProc2) (Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, void *clientData, size_t objc, Tcl_Obj *const objv[]); /* 679 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
#ifdef __cplusplus
}
#endif
|
| ︙ | ︙ | |||
2571 2572 2573 2574 2575 2576 2577 | (tclStubsPtr->tclGetStringFromObj) /* 41 */ #define Tcl_InvalidateStringRep \ (tclStubsPtr->tcl_InvalidateStringRep) /* 42 */ #define Tcl_ListObjAppendList \ (tclStubsPtr->tcl_ListObjAppendList) /* 43 */ #define Tcl_ListObjAppendElement \ (tclStubsPtr->tcl_ListObjAppendElement) /* 44 */ | | | | | | 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 | (tclStubsPtr->tclGetStringFromObj) /* 41 */ #define Tcl_InvalidateStringRep \ (tclStubsPtr->tcl_InvalidateStringRep) /* 42 */ #define Tcl_ListObjAppendList \ (tclStubsPtr->tcl_ListObjAppendList) /* 43 */ #define Tcl_ListObjAppendElement \ (tclStubsPtr->tcl_ListObjAppendElement) /* 44 */ #define TclListObjGetElements \ (tclStubsPtr->tclListObjGetElements) /* 45 */ #define Tcl_ListObjIndex \ (tclStubsPtr->tcl_ListObjIndex) /* 46 */ #define TclListObjLength \ (tclStubsPtr->tclListObjLength) /* 47 */ #define Tcl_ListObjReplace \ (tclStubsPtr->tcl_ListObjReplace) /* 48 */ /* Slot 49 is reserved */ #define Tcl_NewByteArrayObj \ (tclStubsPtr->tcl_NewByteArrayObj) /* 50 */ #define Tcl_NewDoubleObj \ (tclStubsPtr->tcl_NewDoubleObj) /* 51 */ |
| ︙ | ︙ | |||
2633 2634 2635 2636 2637 2638 2639 | /* Slot 77 is reserved */ #define Tcl_BadChannelOption \ (tclStubsPtr->tcl_BadChannelOption) /* 78 */ #define Tcl_CallWhenDeleted \ (tclStubsPtr->tcl_CallWhenDeleted) /* 79 */ #define Tcl_CancelIdleCall \ (tclStubsPtr->tcl_CancelIdleCall) /* 80 */ | > | | 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 | /* Slot 77 is reserved */ #define Tcl_BadChannelOption \ (tclStubsPtr->tcl_BadChannelOption) /* 78 */ #define Tcl_CallWhenDeleted \ (tclStubsPtr->tcl_CallWhenDeleted) /* 79 */ #define Tcl_CancelIdleCall \ (tclStubsPtr->tcl_CancelIdleCall) /* 80 */ #define Tcl_Close \ (tclStubsPtr->tcl_Close) /* 81 */ #define Tcl_CommandComplete \ (tclStubsPtr->tcl_CommandComplete) /* 82 */ #define Tcl_Concat \ (tclStubsPtr->tcl_Concat) /* 83 */ #define Tcl_ConvertElement \ (tclStubsPtr->tcl_ConvertElement) /* 84 */ #define Tcl_ConvertCountedElement \ |
| ︙ | ︙ | |||
2940 2941 2942 2943 2944 2945 2946 | (tclStubsPtr->tcl_SetVar2) /* 238 */ #define Tcl_SignalId \ (tclStubsPtr->tcl_SignalId) /* 239 */ #define Tcl_SignalMsg \ (tclStubsPtr->tcl_SignalMsg) /* 240 */ #define Tcl_SourceRCFile \ (tclStubsPtr->tcl_SourceRCFile) /* 241 */ | | | | | | 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 | (tclStubsPtr->tcl_SetVar2) /* 238 */ #define Tcl_SignalId \ (tclStubsPtr->tcl_SignalId) /* 239 */ #define Tcl_SignalMsg \ (tclStubsPtr->tcl_SignalMsg) /* 240 */ #define Tcl_SourceRCFile \ (tclStubsPtr->tcl_SourceRCFile) /* 241 */ #define TclSplitList \ (tclStubsPtr->tclSplitList) /* 242 */ #define TclSplitPath \ (tclStubsPtr->tclSplitPath) /* 243 */ /* Slot 244 is reserved */ /* Slot 245 is reserved */ /* Slot 246 is reserved */ /* Slot 247 is reserved */ #define Tcl_TraceVar2 \ (tclStubsPtr->tcl_TraceVar2) /* 248 */ #define Tcl_TranslateFileName \ |
| ︙ | ︙ | |||
3345 3346 3347 3348 3349 3350 3351 | (tclStubsPtr->tcl_FSGetCwd) /* 457 */ #define Tcl_FSChdir \ (tclStubsPtr->tcl_FSChdir) /* 458 */ #define Tcl_FSConvertToPathType \ (tclStubsPtr->tcl_FSConvertToPathType) /* 459 */ #define Tcl_FSJoinPath \ (tclStubsPtr->tcl_FSJoinPath) /* 460 */ | | | | 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 | (tclStubsPtr->tcl_FSGetCwd) /* 457 */ #define Tcl_FSChdir \ (tclStubsPtr->tcl_FSChdir) /* 458 */ #define Tcl_FSConvertToPathType \ (tclStubsPtr->tcl_FSConvertToPathType) /* 459 */ #define Tcl_FSJoinPath \ (tclStubsPtr->tcl_FSJoinPath) /* 460 */ #define TclFSSplitPath \ (tclStubsPtr->tclFSSplitPath) /* 461 */ #define Tcl_FSEqualPaths \ (tclStubsPtr->tcl_FSEqualPaths) /* 462 */ #define Tcl_FSGetNormalizedPath \ (tclStubsPtr->tcl_FSGetNormalizedPath) /* 463 */ #define Tcl_FSJoinToPath \ (tclStubsPtr->tcl_FSJoinToPath) /* 464 */ #define Tcl_FSGetInternalRep \ |
| ︙ | ︙ | |||
3417 3418 3419 3420 3421 3422 3423 | (tclStubsPtr->tcl_ChannelWideSeekProc) /* 493 */ #define Tcl_DictObjPut \ (tclStubsPtr->tcl_DictObjPut) /* 494 */ #define Tcl_DictObjGet \ (tclStubsPtr->tcl_DictObjGet) /* 495 */ #define Tcl_DictObjRemove \ (tclStubsPtr->tcl_DictObjRemove) /* 496 */ | | | | 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 | (tclStubsPtr->tcl_ChannelWideSeekProc) /* 493 */ #define Tcl_DictObjPut \ (tclStubsPtr->tcl_DictObjPut) /* 494 */ #define Tcl_DictObjGet \ (tclStubsPtr->tcl_DictObjGet) /* 495 */ #define Tcl_DictObjRemove \ (tclStubsPtr->tcl_DictObjRemove) /* 496 */ #define TclDictObjSize \ (tclStubsPtr->tclDictObjSize) /* 497 */ #define Tcl_DictObjFirst \ (tclStubsPtr->tcl_DictObjFirst) /* 498 */ #define Tcl_DictObjNext \ (tclStubsPtr->tcl_DictObjNext) /* 499 */ #define Tcl_DictObjDone \ (tclStubsPtr->tcl_DictObjDone) /* 500 */ #define Tcl_DictObjPutKeyList \ |
| ︙ | ︙ | |||
3630 3631 3632 3633 3634 3635 3636 | (tclStubsPtr->tcl_GetBlocksFromStat) /* 600 */ #define Tcl_GetBlockSizeFromStat \ (tclStubsPtr->tcl_GetBlockSizeFromStat) /* 601 */ #define Tcl_SetEnsembleParameterList \ (tclStubsPtr->tcl_SetEnsembleParameterList) /* 602 */ #define Tcl_GetEnsembleParameterList \ (tclStubsPtr->tcl_GetEnsembleParameterList) /* 603 */ | | | | 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 | (tclStubsPtr->tcl_GetBlocksFromStat) /* 600 */ #define Tcl_GetBlockSizeFromStat \ (tclStubsPtr->tcl_GetBlockSizeFromStat) /* 601 */ #define Tcl_SetEnsembleParameterList \ (tclStubsPtr->tcl_SetEnsembleParameterList) /* 602 */ #define Tcl_GetEnsembleParameterList \ (tclStubsPtr->tcl_GetEnsembleParameterList) /* 603 */ #define TclParseArgsObjv \ (tclStubsPtr->tclParseArgsObjv) /* 604 */ #define Tcl_GetErrorLine \ (tclStubsPtr->tcl_GetErrorLine) /* 605 */ #define Tcl_SetErrorLine \ (tclStubsPtr->tcl_SetErrorLine) /* 606 */ #define Tcl_TransferResult \ (tclStubsPtr->tcl_TransferResult) /* 607 */ #define Tcl_InterpActive \ |
| ︙ | ︙ | |||
3744 3745 3746 3747 3748 3749 3750 | (tclStubsPtr->tcl_UniCharIsUnicode) /* 657 */ #define Tcl_ExternalToUtfDStringEx \ (tclStubsPtr->tcl_ExternalToUtfDStringEx) /* 658 */ #define Tcl_UtfToExternalDStringEx \ (tclStubsPtr->tcl_UtfToExternalDStringEx) /* 659 */ #define Tcl_AsyncMarkFromSignal \ (tclStubsPtr->tcl_AsyncMarkFromSignal) /* 660 */ | > | > | > | > | > | > | > | > > > > > > > > > > | 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 | (tclStubsPtr->tcl_UniCharIsUnicode) /* 657 */ #define Tcl_ExternalToUtfDStringEx \ (tclStubsPtr->tcl_ExternalToUtfDStringEx) /* 658 */ #define Tcl_UtfToExternalDStringEx \ (tclStubsPtr->tcl_UtfToExternalDStringEx) /* 659 */ #define Tcl_AsyncMarkFromSignal \ (tclStubsPtr->tcl_AsyncMarkFromSignal) /* 660 */ #define Tcl_ListObjGetElements \ (tclStubsPtr->tcl_ListObjGetElements) /* 661 */ #define Tcl_ListObjLength \ (tclStubsPtr->tcl_ListObjLength) /* 662 */ #define Tcl_DictObjSize \ (tclStubsPtr->tcl_DictObjSize) /* 663 */ #define Tcl_SplitList \ (tclStubsPtr->tcl_SplitList) /* 664 */ #define Tcl_SplitPath \ (tclStubsPtr->tcl_SplitPath) /* 665 */ #define Tcl_FSSplitPath \ (tclStubsPtr->tcl_FSSplitPath) /* 666 */ #define Tcl_ParseArgsObjv \ (tclStubsPtr->tcl_ParseArgsObjv) /* 667 */ #define Tcl_UniCharLen \ (tclStubsPtr->tcl_UniCharLen) /* 668 */ #define Tcl_NumUtfChars \ (tclStubsPtr->tcl_NumUtfChars) /* 669 */ #define Tcl_GetCharLength \ (tclStubsPtr->tcl_GetCharLength) /* 670 */ #define Tcl_UtfAtIndex \ (tclStubsPtr->tcl_UtfAtIndex) /* 671 */ #define Tcl_GetRange \ (tclStubsPtr->tcl_GetRange) /* 672 */ #define Tcl_GetUniChar \ (tclStubsPtr->tcl_GetUniChar) /* 673 */ /* Slot 674 is reserved */ /* Slot 675 is reserved */ #define Tcl_CreateObjCommand2 \ (tclStubsPtr->tcl_CreateObjCommand2) /* 676 */ #define Tcl_CreateObjTrace2 \ (tclStubsPtr->tcl_CreateObjTrace2) /* 677 */ #define Tcl_NRCreateCommand2 \ (tclStubsPtr->tcl_NRCreateCommand2) /* 678 */ #define Tcl_NRCallObjProc2 \ (tclStubsPtr->tcl_NRCallObjProc2) /* 679 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #ifdef _WIN32 # undef Tcl_CreateFileHandler |
| ︙ | ︙ | |||
3807 3808 3809 3810 3811 3812 3813 | #define Tcl_UntraceVar(interp, varName, flags, proc, clientData) \ Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData) #define Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) \ Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, prevClientData) #define Tcl_UpVar(interp, frameName, varName, localName, flags) \ Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags) #define Tcl_AddErrorInfo(interp, message) \ | | | | | | 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 |
#define Tcl_UntraceVar(interp, varName, flags, proc, clientData) \
Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData)
#define Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) \
Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, prevClientData)
#define Tcl_UpVar(interp, frameName, varName, localName, flags) \
Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags)
#define Tcl_AddErrorInfo(interp, message) \
Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, TCL_INDEX_NONE))
#define Tcl_AddObjErrorInfo(interp, message, length) \
Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length))
#define Tcl_Eval(interp, objPtr) \
Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, 0)
#define Tcl_GlobalEval(interp, objPtr) \
Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, TCL_EVAL_GLOBAL)
#define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp))
#define Tcl_SaveResult(interp, statePtr) \
do { \
*(statePtr) = Tcl_GetObjResult(interp); \
Tcl_IncrRefCount(*(statePtr)); \
Tcl_SetObjResult(interp, Tcl_NewObj()); \
} while(0)
#define Tcl_RestoreResult(interp, statePtr) \
do { \
Tcl_ResetResult(interp); \
Tcl_SetObjResult(interp, *(statePtr)); \
Tcl_DecrRefCount(*(statePtr)); \
} while(0)
#define Tcl_DiscardResult(statePtr) \
Tcl_DecrRefCount(*(statePtr))
#define Tcl_SetResult(interp, result, freeProc) \
do { \
const char *__result = result; \
Tcl_FreeProc *__freeProc = freeProc; \
Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, TCL_INDEX_NONE)); \
if (__result != NULL && __freeProc != NULL && __freeProc != TCL_VOLATILE) { \
if (__freeProc == TCL_DYNAMIC) { \
Tcl_Free((char *)__result); \
} else { \
(*__freeProc)((char *)__result); \
} \
} \
|
| ︙ | ︙ | |||
3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 | #define Tcl_GetString(objPtr) \ Tcl_GetStringFromObj(objPtr, (size_t *)NULL) #define Tcl_GetUnicode(objPtr) \ Tcl_GetUnicodeFromObj(objPtr, (size_t *)NULL) #undef Tcl_GetIndexFromObjStruct #undef Tcl_GetStringFromObj #undef Tcl_GetUnicodeFromObj #undef Tcl_GetByteArrayFromObj #undef Tcl_GetBytesFromObj #if defined(USE_TCL_STUBS) #define Tcl_GetStringFromObj(objPtr, sizePtr) \ | > > > | > > | > > | > > | | > > > | > > | > > | > > | | > | 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 |
#define Tcl_GetString(objPtr) \
Tcl_GetStringFromObj(objPtr, (size_t *)NULL)
#define Tcl_GetUnicode(objPtr) \
Tcl_GetUnicodeFromObj(objPtr, (size_t *)NULL)
#undef Tcl_GetIndexFromObjStruct
#undef Tcl_GetStringFromObj
#undef Tcl_GetUnicodeFromObj
#undef TclGetByteArrayFromObj
#undef Tcl_GetByteArrayFromObj
#undef Tcl_GetBytesFromObj
#if defined(USE_TCL_STUBS)
#define Tcl_GetStringFromObj(objPtr, sizePtr) \
((sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \
tclStubsPtr->tclGetStringFromObj(objPtr, (int *)(void *)(sizePtr)) : \
tclStubsPtr->tcl_GetStringFromObj(objPtr, (size_t *)(void *)(sizePtr)))
#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \
((sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \
tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(void *)(sizePtr)) : \
tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(void *)(sizePtr)))
#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
((sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \
tclStubsPtr->tclGetBytesFromObj(NULL, objPtr, (int *)(void *)(sizePtr)) : \
tclStubsPtr->tcl_GetBytesFromObj(NULL, objPtr, (size_t *)(void *)(sizePtr)))
#define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \
((sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \
tclStubsPtr->tclGetUnicodeFromObj(objPtr, (int *)(void *)(sizePtr)) : \
tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (size_t *)(void *)(sizePtr)))
#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \
(tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), \
(flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr)))
#else
#define Tcl_GetStringFromObj(objPtr, sizePtr) \
((sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \
(TclGetStringFromObj)(objPtr, (int *)(void *)(sizePtr)) : \
(Tcl_GetStringFromObj)(objPtr, (size_t *)(void *)(sizePtr)))
#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \
((sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \
(TclGetBytesFromObj)(interp, objPtr, (int *)(void *)(sizePtr)) : \
(Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(void *)(sizePtr)))
#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
((sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \
(TclGetBytesFromObj)(NULL, objPtr, (int *)(void *)(sizePtr)) : \
(Tcl_GetBytesFromObj)(NULL, objPtr, (size_t *)(void *)(sizePtr)))
#define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \
((sizeof(*(sizePtr)) == sizeof(int) && sizeof(int) != sizeof(size_t)) ? \
(TclGetUnicodeFromObj)(objPtr, (int *)(void *)(sizePtr)) : \
Tcl_GetUnicodeFromObj(objPtr, (size_t *)(void *)(sizePtr)))
#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \
((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), \
(flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr)))
#endif
#ifdef TCL_MEM_DEBUG
# undef Tcl_Alloc
# define Tcl_Alloc(x) \
(Tcl_DbCkalloc((x), __FILE__, __LINE__))
# undef Tcl_Free
|
| ︙ | ︙ | |||
3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 | # define Tcl_UniCharToUtfDString Tcl_Char16ToUtfDString # undef Tcl_UtfToUniCharDString # define Tcl_UtfToUniCharDString Tcl_UtfToChar16DString # undef Tcl_UtfToUniChar # define Tcl_UtfToUniChar Tcl_UtfToChar16 # undef Tcl_UniCharLen # define Tcl_UniCharLen Tcl_Char16Len #if !defined(BUILD_tcl) # undef Tcl_NumUtfChars # define Tcl_NumUtfChars TclNumUtfChars # undef Tcl_GetCharLength # define Tcl_GetCharLength TclGetCharLength # undef Tcl_UtfAtIndex # define Tcl_UtfAtIndex TclUtfAtIndex | > > > > > > > > | 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 | # define Tcl_UniCharToUtfDString Tcl_Char16ToUtfDString # undef Tcl_UtfToUniCharDString # define Tcl_UtfToUniCharDString Tcl_UtfToChar16DString # undef Tcl_UtfToUniChar # define Tcl_UtfToUniChar Tcl_UtfToChar16 # undef Tcl_UniCharLen # define Tcl_UniCharLen Tcl_Char16Len # undef Tcl_UniCharToUtf # if defined(USE_TCL_STUBS) # define Tcl_UniCharToUtf(c, p) \ (tclStubsPtr->tcl_UniCharToUtf((c)|TCL_COMBINE, (p))) # else # define Tcl_UniCharToUtf(c, p) \ ((Tcl_UniCharToUtf)((c)|TCL_COMBINE, (p))) # endif #if !defined(BUILD_tcl) # undef Tcl_NumUtfChars # define Tcl_NumUtfChars TclNumUtfChars # undef Tcl_GetCharLength # define Tcl_GetCharLength TclGetCharLength # undef Tcl_UtfAtIndex # define Tcl_UtfAtIndex TclUtfAtIndex |
| ︙ | ︙ | |||
3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 | : (wchar_t *(*)(const char *, size_t, Tcl_DString *))Tcl_UtfToChar16DString) # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ ? (int (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToUniChar \ : (int (*)(const char *, wchar_t *))Tcl_UtfToChar16) # define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ ? (size_t (*)(wchar_t *))tclStubsPtr->tcl_UniCharLen \ : (size_t (*)(wchar_t *))Tcl_Char16Len) #else # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ ? (char *(*)(const wchar_t *, size_t, Tcl_DString *))Tcl_UniCharToUtfDString \ : (char *(*)(const wchar_t *, size_t, Tcl_DString *))Tcl_Char16ToUtfDString) # define Tcl_UtfToWCharDString (sizeof(wchar_t) != sizeof(short) \ ? (wchar_t *(*)(const char *, size_t, Tcl_DString *))Tcl_UtfToUniCharDString \ : (wchar_t *(*)(const char *, size_t, Tcl_DString *))Tcl_UtfToChar16DString) # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ ? (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar \ : (int (*)(const char *, wchar_t *))Tcl_UtfToChar16) # define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ ? (size_t (*)(wchar_t *))Tcl_UniCharLen \ : (size_t (*)(wchar_t *))Tcl_Char16Len) #endif /* * Deprecated Tcl procedures: */ #define Tcl_EvalObj(interp, objPtr) \ | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 | : (wchar_t *(*)(const char *, size_t, Tcl_DString *))Tcl_UtfToChar16DString) # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ ? (int (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToUniChar \ : (int (*)(const char *, wchar_t *))Tcl_UtfToChar16) # define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ ? (size_t (*)(wchar_t *))tclStubsPtr->tcl_UniCharLen \ : (size_t (*)(wchar_t *))Tcl_Char16Len) # undef Tcl_ListObjGetElements # define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) == sizeof(size_t) \ ? tclStubsPtr->tcl_ListObjGetElements((interp), (listPtr), (size_t *)(void *)(objcPtr), (objvPtr)) \ : tclStubsPtr->tclListObjGetElements((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr))) # undef Tcl_ListObjLength # define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) == sizeof(size_t) \ ? tclStubsPtr->tcl_ListObjLength((interp), (listPtr), (size_t *)(void *)(lengthPtr)) \ : tclStubsPtr->tclListObjLength((interp), (listPtr), (int *)(void *)(lengthPtr))) # undef Tcl_DictObjSize # define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) == sizeof(size_t) \ ? tclStubsPtr->tcl_DictObjSize((interp), (dictPtr), (size_t *)(void *)(sizePtr)) \ : tclStubsPtr->tclDictObjSize((interp), (dictPtr), (int *)(void *)(sizePtr))) # undef Tcl_SplitList # define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(size_t) \ ? tclStubsPtr->tcl_SplitList((interp), (listStr), (size_t *)(void *)(argcPtr), (argvPtr)) \ : tclStubsPtr->tclSplitList((interp), (listStr), (int *)(void *)(argcPtr), (argvPtr))) # undef Tcl_SplitPath # define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(size_t) \ ? tclStubsPtr->tcl_SplitPath((path), (size_t *)(void *)(argcPtr), (argvPtr)) \ : tclStubsPtr->tclSplitPath((path), (int *)(void *)(argcPtr), (argvPtr))) # undef Tcl_FSSplitPath # define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) == sizeof(size_t) \ ? tclStubsPtr->tcl_FSSplitPath((pathPtr), (size_t *)(void *)(lenPtr)) \ : tclStubsPtr->tclFSSplitPath((pathPtr), (int *)(void *)(lenPtr))) # undef Tcl_ParseArgsObjv # define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) == sizeof(size_t) \ ? tclStubsPtr->tcl_ParseArgsObjv((interp), (argTable), (size_t *)(void *)(objcPtr), (objv), (remObjv)) \ : tclStubsPtr->tclParseArgsObjv((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv))) #else # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ ? (char *(*)(const wchar_t *, size_t, Tcl_DString *))Tcl_UniCharToUtfDString \ : (char *(*)(const wchar_t *, size_t, Tcl_DString *))Tcl_Char16ToUtfDString) # define Tcl_UtfToWCharDString (sizeof(wchar_t) != sizeof(short) \ ? (wchar_t *(*)(const char *, size_t, Tcl_DString *))Tcl_UtfToUniCharDString \ : (wchar_t *(*)(const char *, size_t, Tcl_DString *))Tcl_UtfToChar16DString) # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ ? (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar \ : (int (*)(const char *, wchar_t *))Tcl_UtfToChar16) # define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ ? (size_t (*)(wchar_t *))Tcl_UniCharLen \ : (size_t (*)(wchar_t *))Tcl_Char16Len) # define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) == sizeof(size_t) \ ? (Tcl_ListObjGetElements)((interp), (listPtr), (size_t *)(void *)(objcPtr), (objvPtr)) \ : TclListObjGetElements((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr))) # define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) == sizeof(size_t) \ ? (Tcl_ListObjLength)((interp), (listPtr), (size_t *)(void *)(lengthPtr)) \ : TclListObjLength((interp), (listPtr), (int *)(void *)(lengthPtr))) # define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) == sizeof(size_t) \ ? (Tcl_DictObjSize)((interp), (dictPtr), (size_t *)(void *)(sizePtr)) \ : TclDictObjSize((interp), (dictPtr), (int *)(void *)(sizePtr))) # define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(size_t) \ ? (Tcl_SplitList)((interp), (listStr), (size_t *)(void *)(argcPtr), (argvPtr)) \ : TclSplitList((interp), (listStr), (int *)(void *)(argcPtr), (argvPtr))) # define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(size_t) \ ? (Tcl_SplitPath)((path), (size_t *)(void *)(argcPtr), (argvPtr)) \ : TclSplitPath((path), (int *)(void *)(argcPtr), (argvPtr))) # define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) == sizeof(size_t) \ ? (Tcl_FSSplitPath)((pathPtr), (size_t *)(void *)(lenPtr)) \ : TclFSSplitPath((pathPtr), (int *)(void *)(lenPtr))) # define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) == sizeof(size_t) \ ? (Tcl_ParseArgsObjv)((interp), (argTable), (size_t *)(void *)(objcPtr), (objv), (remObjv)) \ : TclParseArgsObjv((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv))) #endif /* * Deprecated Tcl procedures: */ #define Tcl_EvalObj(interp, objPtr) \ |
| ︙ | ︙ | |||
4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 | # define Tcl_WriteChars(chan, src, srcLen) (((Tcl_WideInt)((Tcl_WriteChars)(chan, src, srcLen)+1))-1) # define Tcl_WriteObj(chan, objPtr) (((Tcl_WideInt)((Tcl_WriteObj)(chan, objPtr)+1))-1) # define Tcl_ReadRaw(chan, dst, bytesToRead) (((Tcl_WideInt)((Tcl_ReadRaw)(chan, dst, bytesToRead)+1))-1) # define Tcl_WriteRaw(chan, src, srcLen) (((Tcl_WideInt)((Tcl_WriteRaw()(chan, src, srcLen)+1))-1) # endif #endif #define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0) #undef TclUtfCharComplete #undef TclUtfNext #undef TclUtfPrev #ifndef TCL_NO_DEPRECATED # define Tcl_CreateSlave Tcl_CreateChild # define Tcl_GetSlave Tcl_GetChild # define Tcl_GetMaster Tcl_GetParent #endif #endif /* _TCLDECLS */ | > | 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 | # define Tcl_WriteChars(chan, src, srcLen) (((Tcl_WideInt)((Tcl_WriteChars)(chan, src, srcLen)+1))-1) # define Tcl_WriteObj(chan, objPtr) (((Tcl_WideInt)((Tcl_WriteObj)(chan, objPtr)+1))-1) # define Tcl_ReadRaw(chan, dst, bytesToRead) (((Tcl_WideInt)((Tcl_ReadRaw)(chan, dst, bytesToRead)+1))-1) # define Tcl_WriteRaw(chan, src, srcLen) (((Tcl_WideInt)((Tcl_WriteRaw()(chan, src, srcLen)+1))-1) # endif #endif #undef Tcl_Close #define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0) #undef TclUtfCharComplete #undef TclUtfNext #undef TclUtfPrev #ifndef TCL_NO_DEPRECATED # define Tcl_CreateSlave Tcl_CreateChild # define Tcl_GetSlave Tcl_GetChild # define Tcl_GetMaster Tcl_GetParent #endif #endif /* _TCLDECLS */ |
Changes to generic/tclDictObj.c.
| ︙ | ︙ | |||
598 599 600 601 602 603 604 |
/*
* Since lists and dictionaries have very closely-related string
* representations (i.e. the same parsing code) we can safely special-case
* the conversion from lists to dictionaries.
*/
if (TclHasInternalRep(objPtr, &tclListType)) {
| | | | 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 |
/*
* Since lists and dictionaries have very closely-related string
* representations (i.e. the same parsing code) we can safely special-case
* the conversion from lists to dictionaries.
*/
if (TclHasInternalRep(objPtr, &tclListType)) {
size_t objc, i;
Tcl_Obj **objv;
/* Cannot fail, we already know the Tcl_ObjType is "list". */
TclListObjGetElementsM(NULL, objPtr, &objc, &objv);
if (objc & 1) {
goto missingValue;
}
for (i=0 ; i<objc ; i+=2) {
/* Store key and value in the hash table we're building. */
|
| ︙ | ︙ | |||
1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 |
* Side effects:
* The dictPtr object is converted to a dictionary type if it is not a
* dictionary already.
*
*----------------------------------------------------------------------
*/
int
Tcl_DictObjSize(
Tcl_Interp *interp,
Tcl_Obj *dictPtr,
| > | | 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 |
* Side effects:
* The dictPtr object is converted to a dictionary type if it is not a
* dictionary already.
*
*----------------------------------------------------------------------
*/
#undef Tcl_DictObjSize
int
Tcl_DictObjSize(
Tcl_Interp *interp,
Tcl_Obj *dictPtr,
size_t *sizePtr)
{
Dict *dict;
dict = GetDictFromObj(interp, dictPtr);
if (dict == NULL) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1274 1275 1276 1277 1278 1279 1280 |
*----------------------------------------------------------------------
*/
int
Tcl_DictObjPutKeyList(
Tcl_Interp *interp,
Tcl_Obj *dictPtr,
| | | | 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 |
*----------------------------------------------------------------------
*/
int
Tcl_DictObjPutKeyList(
Tcl_Interp *interp,
Tcl_Obj *dictPtr,
size_t keyc,
Tcl_Obj *const keyv[],
Tcl_Obj *valuePtr)
{
Dict *dict;
Tcl_HashEntry *hPtr;
int isNew;
if (Tcl_IsShared(dictPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_DictObjPutKeyList");
}
if (keyc + 1 < 2) {
Tcl_Panic("%s called with empty key list", "Tcl_DictObjPutKeyList");
}
dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_CREATE);
if (dictPtr == NULL) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1335 1336 1337 1338 1339 1340 1341 |
*----------------------------------------------------------------------
*/
int
Tcl_DictObjRemoveKeyList(
Tcl_Interp *interp,
Tcl_Obj *dictPtr,
| | | 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 |
*----------------------------------------------------------------------
*/
int
Tcl_DictObjRemoveKeyList(
Tcl_Interp *interp,
Tcl_Obj *dictPtr,
size_t keyc,
Tcl_Obj *const keyv[])
{
Dict *dict;
if (Tcl_IsShared(dictPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_DictObjRemoveKeyList");
}
|
| ︙ | ︙ | |||
2017 2018 2019 2020 2021 2022 2023 |
static int
DictSizeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
| | > | 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 |
static int
DictSizeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
int result;
size_t size;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
return TCL_ERROR;
}
result = Tcl_DictObjSize(interp, objv[1], &size);
if (result == TCL_OK) {
|
| ︙ | ︙ | |||
2455 2456 2457 2458 2459 2460 2461 |
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
Tcl_Obj **varv, *keyObj, *valueObj;
Tcl_DictSearch *searchPtr;
| > | | | | 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 |
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
Tcl_Obj **varv, *keyObj, *valueObj;
Tcl_DictSearch *searchPtr;
size_t varc;
int done;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"{keyVarName valueVarName} dictionary script");
return TCL_ERROR;
}
/*
* Parse arguments.
*/
if (TclListObjGetElementsM(interp, objv[1], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
if (varc != 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must have exactly two variable names", -1));
Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "for", NULL);
return TCL_ERROR;
}
searchPtr = (Tcl_DictSearch *)TclStackAlloc(interp, sizeof(Tcl_DictSearch));
if (Tcl_DictObjFirst(interp, objv[2], searchPtr, &keyObj, &valueObj,
&done) != TCL_OK) {
TclStackFree(interp, searchPtr);
return TCL_ERROR;
}
if (done) {
TclStackFree(interp, searchPtr);
return TCL_OK;
}
TclListObjGetElementsM(NULL, objv[1], &varc, &varv);
keyVarObj = varv[0];
valueVarObj = varv[1];
scriptObj = objv[3];
/*
* Make sure that these objects (which we need throughout the body of the
* loop) don't vanish. Note that the dictionary internal rep is locked
|
| ︙ | ︙ | |||
2541 2542 2543 2544 2545 2546 2547 |
Tcl_DictObjDone(searchPtr);
TclStackFree(interp, searchPtr);
return TCL_ERROR;
}
static int
DictForLoopCallback(
| | | 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 |
Tcl_DictObjDone(searchPtr);
TclStackFree(interp, searchPtr);
return TCL_ERROR;
}
static int
DictForLoopCallback(
void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_DictSearch *searchPtr = (Tcl_DictSearch *)data[0];
Tcl_Obj *keyVarObj = (Tcl_Obj *)data[1];
Tcl_Obj *valueVarObj = (Tcl_Obj *)data[2];
|
| ︙ | ︙ | |||
2649 2650 2651 2652 2653 2654 2655 |
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj **varv, *keyObj, *valueObj;
DictMapStorage *storagePtr;
| > | | | 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 |
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj **varv, *keyObj, *valueObj;
DictMapStorage *storagePtr;
size_t varc;
int done;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"{keyVarName valueVarName} dictionary script");
return TCL_ERROR;
}
/*
* Parse arguments.
*/
if (TclListObjGetElementsM(interp, objv[1], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
if (varc != 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must have exactly two variable names", -1));
Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "map", NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
2687 2688 2689 2690 2691 2692 2693 |
* an empty dictionary.
*/
TclStackFree(interp, storagePtr);
return TCL_OK;
}
TclNewObj(storagePtr->accumulatorObj);
| | | 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 |
* an empty dictionary.
*/
TclStackFree(interp, storagePtr);
return TCL_OK;
}
TclNewObj(storagePtr->accumulatorObj);
TclListObjGetElementsM(NULL, objv[1], &varc, &varv);
storagePtr->keyVarObj = varv[0];
storagePtr->valueVarObj = varv[1];
storagePtr->scriptObj = objv[3];
/*
* Make sure that these objects (which we need throughout the body of the
* loop) don't vanish. Note that the dictionary internal rep is locked
|
| ︙ | ︙ | |||
2745 2746 2747 2748 2749 2750 2751 |
Tcl_DictObjDone(&storagePtr->search);
TclStackFree(interp, storagePtr);
return TCL_ERROR;
}
static int
DictMapLoopCallback(
| | | 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 |
Tcl_DictObjDone(&storagePtr->search);
TclStackFree(interp, storagePtr);
return TCL_ERROR;
}
static int
DictMapLoopCallback(
void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
DictMapStorage *storagePtr = (DictMapStorage *)data[0];
Tcl_Obj *keyObj, *valueObj;
int done;
|
| ︙ | ︙ | |||
2987 2988 2989 2990 2991 2992 2993 |
};
enum FilterTypes {
FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES
} index;
Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
Tcl_Obj **varv, *keyObj = NULL, *valueObj = NULL, *resultObj, *boolObj;
Tcl_DictSearch search;
| | > | 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 |
};
enum FilterTypes {
FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES
} index;
Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
Tcl_Obj **varv, *keyObj = NULL, *valueObj = NULL, *resultObj, *boolObj;
Tcl_DictSearch search;
int done, result, satisfied;
size_t varc;
const char *pattern;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary filterType ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], filters, "filterType",
|
| ︙ | ︙ | |||
3100 3101 3102 3103 3104 3105 3106 | /* * Create a dictionary whose key,value pairs all satisfy a script * (i.e. get a true boolean result from its evaluation). Massive * copying from the "dict for" implementation has occurred! */ | | | 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 |
/*
* Create a dictionary whose key,value pairs all satisfy a script
* (i.e. get a true boolean result from its evaluation). Massive
* copying from the "dict for" implementation has occurred!
*/
if (TclListObjGetElementsM(interp, objv[3], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
if (varc != 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must have exactly two variable names", -1));
Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "filter", NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
3264 3265 3266 3267 3268 3269 3270 |
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *dictPtr, *objPtr;
| | > | 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 |
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *dictPtr, *objPtr;
int i;
size_t dummy;
if (objc < 5 || !(objc & 1)) {
Tcl_WrongNumArgs(interp, 1, objv,
"dictVarName key varName ?key varName ...? script");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
3311 3312 3313 3314 3315 3316 3317 |
TclNRAddCallback(interp, FinalizeDictUpdate, objv[1], objPtr, NULL,NULL);
return TclNREvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1);
}
static int
FinalizeDictUpdate(
| | | | 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 |
TclNRAddCallback(interp, FinalizeDictUpdate, objv[1], objPtr, NULL,NULL);
return TclNREvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1);
}
static int
FinalizeDictUpdate(
void *data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj *dictPtr, *objPtr, **objv;
Tcl_InterpState state;
size_t i, objc;
Tcl_Obj *varName = (Tcl_Obj *)data[0];
Tcl_Obj *argsObj = (Tcl_Obj *)data[1];
/*
* ErrorInfo handling.
*/
|
| ︙ | ︙ | |||
3361 3362 3363 3364 3365 3366 3367 |
}
/*
* Write back the values from the variables, treating failure to read as
* an instruction to remove the key.
*/
| | | 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 |
}
/*
* Write back the values from the variables, treating failure to read as
* an instruction to remove the key.
*/
TclListObjGetElementsM(NULL, argsObj, &objc, &objv);
for (i=0 ; i<objc ; i+=2) {
objPtr = Tcl_ObjGetVar2(interp, objv[i+1], NULL, 0);
if (objPtr == NULL) {
Tcl_DictObjRemove(NULL, dictPtr, objv[i]);
} else if (objPtr == dictPtr) {
/*
* Someone is messing us around, trying to build a recursive
|
| ︙ | ︙ | |||
3462 3463 3464 3465 3466 3467 3468 |
NULL);
return TclNREvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1);
}
static int
FinalizeDictWith(
| | | | | 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 |
NULL);
return TclNREvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1);
}
static int
FinalizeDictWith(
void *data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj **pathv;
size_t pathc;
Tcl_InterpState state;
Tcl_Obj *varName = (Tcl_Obj *)data[0];
Tcl_Obj *keysPtr = (Tcl_Obj *)data[1];
Tcl_Obj *pathPtr = (Tcl_Obj *)data[2];
Var *varPtr, *arrayPtr;
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (body of \"dict with\")");
}
/*
* Save the result state; TDWF doesn't guarantee to not modify that on
* TCL_OK result.
*/
state = Tcl_SaveInterpState(interp, result);
if (pathPtr != NULL) {
TclListObjGetElementsM(NULL, pathPtr, &pathc, &pathv);
} else {
pathc = 0;
pathv = NULL;
}
/*
* Pack from local variables back into the dictionary.
|
| ︙ | ︙ | |||
3544 3545 3546 3547 3548 3549 3550 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclDictWithInit(
Tcl_Interp *interp,
Tcl_Obj *dictPtr,
| | | | 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclDictWithInit(
Tcl_Interp *interp,
Tcl_Obj *dictPtr,
size_t pathc,
Tcl_Obj *const pathv[])
{
Tcl_DictSearch s;
Tcl_Obj *keyPtr, *valPtr, *keysPtr;
int done;
if (pathc + 1 > 1) {
dictPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv,
DICT_PATH_READ);
if (dictPtr == NULL) {
return NULL;
}
}
|
| ︙ | ︙ | |||
3631 3632 3633 3634 3635 3636 3637 |
int pathc, /* The number of elements in the path into the
* dictionary. */
Tcl_Obj *const pathv[], /* The elements of the path to the subdict. */
Tcl_Obj *keysPtr) /* List of keys to be synchronized. This is
* the result value from TclDictWithInit. */
{
Tcl_Obj *dictPtr, *leafPtr, *valPtr;
| | | 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 |
int pathc, /* The number of elements in the path into the
* dictionary. */
Tcl_Obj *const pathv[], /* The elements of the path to the subdict. */
Tcl_Obj *keysPtr) /* List of keys to be synchronized. This is
* the result value from TclDictWithInit. */
{
Tcl_Obj *dictPtr, *leafPtr, *valPtr;
size_t i, allocdict, keyc;
Tcl_Obj **keyv;
/*
* If the dictionary variable doesn't exist, drop everything silently.
*/
dictPtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
|
| ︙ | ︙ | |||
3691 3692 3693 3694 3695 3696 3697 |
leafPtr = dictPtr;
}
/*
* Now process our updates on the leaf dictionary.
*/
| | | 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 |
leafPtr = dictPtr;
}
/*
* Now process our updates on the leaf dictionary.
*/
TclListObjGetElementsM(NULL, keysPtr, &keyc, &keyv);
for (i=0 ; i<keyc ; i++) {
valPtr = Tcl_ObjGetVar2(interp, keyv[i], NULL, 0);
if (valPtr == NULL) {
Tcl_DictObjRemove(NULL, leafPtr, keyv[i]);
} else if (leafPtr == valPtr) {
/*
* Someone is messing us around, trying to build a recursive
|
| ︙ | ︙ |
Changes to generic/tclDisassemble.c.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 | static Tcl_Obj * DisassembleByteCodeAsDicts(Tcl_Obj *objPtr); static Tcl_Obj * DisassembleByteCodeObj(Tcl_Obj *objPtr); static int FormatInstruction(ByteCode *codePtr, const unsigned char *pc, Tcl_Obj *bufferObj); static void GetLocationInformation(Proc *procPtr, Tcl_Obj **fileObjPtr, int *linePtr); static void PrintSourceToObj(Tcl_Obj *appendObj, | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | static Tcl_Obj * DisassembleByteCodeAsDicts(Tcl_Obj *objPtr); static Tcl_Obj * DisassembleByteCodeObj(Tcl_Obj *objPtr); static int FormatInstruction(ByteCode *codePtr, const unsigned char *pc, Tcl_Obj *bufferObj); static void GetLocationInformation(Proc *procPtr, Tcl_Obj **fileObjPtr, int *linePtr); static void PrintSourceToObj(Tcl_Obj *appendObj, const char *stringPtr, size_t maxChars); static void UpdateStringOfInstName(Tcl_Obj *objPtr); /* * The structure below defines an instruction name Tcl object to allow * reporting of inner contexts in errorstack without string allocation. */ |
| ︙ | ︙ | |||
52 53 54 55 56 57 58 |
} while (0)
#define InstNameGetInternalRep(objPtr, inst) \
do { \
const Tcl_ObjInternalRep *irPtr; \
irPtr = TclFetchInternalRep((objPtr), &instNameType); \
assert(irPtr != NULL); \
| | | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 |
} while (0)
#define InstNameGetInternalRep(objPtr, inst) \
do { \
const Tcl_ObjInternalRep *irPtr; \
irPtr = TclFetchInternalRep((objPtr), &instNameType); \
assert(irPtr != NULL); \
(inst) = irPtr->wideValue; \
} while (0)
/*
*----------------------------------------------------------------------
*
* GetLocationInformation --
|
| ︙ | ︙ | |||
284 285 286 287 288 289 290 |
TclMin(codePtr->numSrcBytes, 55));
GetLocationInformation(codePtr->procPtr, &fileObj, &line);
if (line >= 0 && fileObj != NULL) {
Tcl_AppendPrintfToObj(bufferObj, "\n File \"%s\" Line %d",
TclGetString(fileObj), line);
}
Tcl_AppendPrintfToObj(bufferObj,
| | | > | | | | | | | 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 |
TclMin(codePtr->numSrcBytes, 55));
GetLocationInformation(codePtr->procPtr, &fileObj, &line);
if (line >= 0 && fileObj != NULL) {
Tcl_AppendPrintfToObj(bufferObj, "\n File \"%s\" Line %d",
TclGetString(fileObj), line);
}
Tcl_AppendPrintfToObj(bufferObj,
"\n Cmds %d, src %" TCL_Z_MODIFIER "u, inst %" TCL_Z_MODIFIER "u, litObjs %" TCL_Z_MODIFIER "u, aux %" TCL_Z_MODIFIER "u, stkDepth %" TCL_Z_MODIFIER "u, code/src %.2f\n",
numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes,
codePtr->numLitObjects, codePtr->numAuxDataItems,
codePtr->maxStackDepth,
#ifdef TCL_COMPILE_STATS
codePtr->numSrcBytes?
codePtr->structureSize/(float)codePtr->numSrcBytes :
#endif
0.0);
#ifdef TCL_COMPILE_STATS
Tcl_AppendPrintfToObj(bufferObj,
" Code %" TCL_Z_MODIFIER "u = header %" TCL_Z_MODIFIER "u+inst %" TCL_Z_MODIFIER "u+litObj %"
TCL_Z_MODIFIER "u+exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER "u+cmdMap %" TCL_Z_MODIFIER "u\n",
codePtr->structureSize,
offsetof(ByteCode, localCachePtr),
codePtr->numCodeBytes,
codePtr->numLitObjects * sizeof(Tcl_Obj *),
codePtr->numExceptRanges*sizeof(ExceptionRange),
codePtr->numAuxDataItems * sizeof(AuxData),
codePtr->numCmdLocBytes);
#endif /* TCL_COMPILE_STATS */
/*
* If the ByteCode is the compiled body of a Tcl procedure, print
* information about that procedure. Note that we don't know the
* procedure's name since ByteCode's can be shared among procedures.
*/
if (codePtr->procPtr != NULL) {
Proc *procPtr = codePtr->procPtr;
int numCompiledLocals = procPtr->numCompiledLocals;
Tcl_AppendPrintfToObj(bufferObj,
" Proc %p, refCt %" TCL_Z_MODIFIER "u, args %" TCL_Z_MODIFIER "u, compiled locals %d\n",
procPtr, procPtr->refCount, procPtr->numArgs,
numCompiledLocals);
if (numCompiledLocals > 0) {
CompiledLocal *localPtr = procPtr->firstLocalPtr;
for (i = 0; i < numCompiledLocals; i++) {
Tcl_AppendPrintfToObj(bufferObj,
|
| ︙ | ︙ | |||
347 348 349 350 351 352 353 |
}
}
/*
* Print the ExceptionRange array.
*/
| | | | | | | | 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 |
}
}
/*
* Print the ExceptionRange array.
*/
if ((int)codePtr->numExceptRanges > 0) {
Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %" TCL_Z_MODIFIER "u, depth %" TCL_Z_MODIFIER "u:\n",
codePtr->numExceptRanges, codePtr->maxExceptDepth);
for (i = 0; i < (int)codePtr->numExceptRanges; i++) {
ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i];
Tcl_AppendPrintfToObj(bufferObj,
" %d: level %" TCL_Z_MODIFIER "u, %s, pc %" TCL_Z_MODIFIER "u-%" TCL_Z_MODIFIER "u, ",
i, rangePtr->nestingLevel,
(rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"),
rangePtr->codeOffset,
(rangePtr->codeOffset + rangePtr->numCodeBytes - 1));
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
Tcl_AppendPrintfToObj(bufferObj, "continue %" TCL_Z_MODIFIER "u, break %" TCL_Z_MODIFIER "u\n",
rangePtr->continueOffset, rangePtr->breakOffset);
break;
case CATCH_EXCEPTION_RANGE:
Tcl_AppendPrintfToObj(bufferObj, "catch %" TCL_Z_MODIFIER "u\n",
rangePtr->catchOffset);
break;
default:
Tcl_Panic("DisassembleByteCodeObj: bad ExceptionRange type %d",
rangePtr->type);
}
}
|
| ︙ | ︙ | |||
538 539 540 541 542 543 544 |
{
Proc *procPtr = codePtr->procPtr;
unsigned char opCode = *pc;
const InstructionDesc *instDesc = &tclInstructionTable[opCode];
unsigned char *codeStart = codePtr->codeStart;
unsigned pcOffset = pc - codeStart;
int opnd = 0, i, j, numBytes = 1;
| | | 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 |
{
Proc *procPtr = codePtr->procPtr;
unsigned char opCode = *pc;
const InstructionDesc *instDesc = &tclInstructionTable[opCode];
unsigned char *codeStart = codePtr->codeStart;
unsigned pcOffset = pc - codeStart;
int opnd = 0, i, j, numBytes = 1;
int localCt = procPtr ? (int)procPtr->numCompiledLocals : 0;
CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL;
char suffixBuffer[128]; /* Additional info to print after main opcode
* and immediates. */
char *suffixSrc = NULL;
Tcl_Obj *suffixObj = NULL;
AuxData *auxPtr = NULL;
|
| ︙ | ︙ | |||
684 685 686 687 688 689 690 |
Tcl_Obj *
TclGetInnerContext(
Tcl_Interp *interp,
const unsigned char *pc,
Tcl_Obj **tosPtr)
{
| | | 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 |
Tcl_Obj *
TclGetInnerContext(
Tcl_Interp *interp,
const unsigned char *pc,
Tcl_Obj **tosPtr)
{
size_t objc = 0;
Tcl_Obj *result;
Interp *iPtr = (Interp *) interp;
switch (*pc) {
case INST_STR_LEN:
case INST_LNOT:
case INST_BITNOT:
|
| ︙ | ︙ | |||
753 754 755 756 757 758 759 |
result = iPtr->innerContext;
if (Tcl_IsShared(result)) {
Tcl_DecrRefCount(result);
iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL);
Tcl_IncrRefCount(result);
} else {
| | | | | 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 |
result = iPtr->innerContext;
if (Tcl_IsShared(result)) {
Tcl_DecrRefCount(result);
iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL);
Tcl_IncrRefCount(result);
} else {
size_t len;
/*
* Reset while keeping the list internalrep as much as possible.
*/
TclListObjLengthM(interp, result, &len);
Tcl_ListObjReplace(interp, result, 0, len, 0, NULL);
}
Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc));
for (; objc>0 ; objc--) {
Tcl_Obj *objPtr;
objPtr = tosPtr[1 - objc];
if (!objPtr) {
Tcl_Panic("InnerContext: bad tos -- appending null object");
}
if ((objPtr->refCount<=0)
#ifdef TCL_MEM_DEBUG
|| (objPtr->refCount==0x61616161)
#endif
|
| ︙ | ︙ | |||
803 804 805 806 807 808 809 |
TclNewInstNameObj(
unsigned char inst)
{
Tcl_Obj *objPtr;
TclNewObj(objPtr);
TclInvalidateStringRep(objPtr);
| | | 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 |
TclNewInstNameObj(
unsigned char inst)
{
Tcl_Obj *objPtr;
TclNewObj(objPtr);
TclInvalidateStringRep(objPtr);
InstNameSetInternalRep(objPtr, inst);
return objPtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
829 830 831 832 833 834 835 |
size_t inst; /* NOTE: We know this is really an unsigned char */
char *dst;
InstNameGetInternalRep(objPtr, inst);
if (inst > LAST_INST_OPCODE) {
dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5);
| | | 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 |
size_t inst; /* NOTE: We know this is really an unsigned char */
char *dst;
InstNameGetInternalRep(objPtr, inst);
if (inst > LAST_INST_OPCODE) {
dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5);
TclOOM(dst, TCL_INTEGER_SPACE + 5);
sprintf(dst, "inst_%" TCL_Z_MODIFIER "u", inst);
(void) Tcl_InitStringRep(objPtr, NULL, strlen(dst));
} else {
const char *s = tclInstructionTable[inst].name;
size_t len = strlen(s);
dst = Tcl_InitStringRep(objPtr, s, len);
TclOOM(dst, len);
|
| ︙ | ︙ | |||
854 855 856 857 858 859 860 |
*----------------------------------------------------------------------
*/
static void
PrintSourceToObj(
Tcl_Obj *appendObj, /* The object to print the source to. */
const char *stringPtr, /* The string to print. */
| | | | 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 |
*----------------------------------------------------------------------
*/
static void
PrintSourceToObj(
Tcl_Obj *appendObj, /* The object to print the source to. */
const char *stringPtr, /* The string to print. */
size_t maxChars) /* Maximum number of chars to print. */
{
const char *p;
size_t i = 0, len;
if (stringPtr == NULL) {
Tcl_AppendToObj(appendObj, "\"\"", -1);
return;
}
Tcl_AppendToObj(appendObj, "\"", -1);
|
| ︙ | ︙ | |||
947 948 949 950 951 952 953 |
ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr);
/*
* Get the literals from the bytecode.
*/
TclNewObj(literals);
| | | 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 |
ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr);
/*
* Get the literals from the bytecode.
*/
TclNewObj(literals);
for (i=0 ; i<(int)codePtr->numLitObjects ; i++) {
Tcl_ListObjAppendElement(NULL, literals, codePtr->objArrayPtr[i]);
}
/*
* Get the variables from the bytecode.
*/
|
| ︙ | ︙ | |||
1107 1108 1109 1110 1111 1112 1113 |
}
/*
* Get the auxiliary data from the bytecode.
*/
TclNewObj(aux);
| | | 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 |
}
/*
* Get the auxiliary data from the bytecode.
*/
TclNewObj(aux);
for (i=0 ; i<(int)codePtr->numAuxDataItems ; i++) {
AuxData *auxData = &codePtr->auxDataArrayPtr[i];
Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1);
if (auxData->type->disassembleProc) {
Tcl_Obj *desc;
TclNewObj(desc);
|
| ︙ | ︙ | |||
1134 1135 1136 1137 1138 1139 1140 |
}
/*
* Get the exception ranges from the bytecode.
*/
TclNewObj(exn);
| | | | | 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 |
}
/*
* Get the exception ranges from the bytecode.
*/
TclNewObj(exn);
for (i=0 ; i<(int)codePtr->numExceptRanges ; i++) {
ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i];
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf(
"type %s level %" TCL_Z_MODIFIER "u from %" TCL_Z_MODIFIER "u to %" TCL_Z_MODIFIER "u break %" TCL_Z_MODIFIER "u continue %" TCL_Z_MODIFIER "u",
"loop", rangePtr->nestingLevel, rangePtr->codeOffset,
rangePtr->codeOffset + rangePtr->numCodeBytes - 1,
rangePtr->breakOffset, rangePtr->continueOffset));
break;
case CATCH_EXCEPTION_RANGE:
Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf(
"type %s level %" TCL_Z_MODIFIER "u from %" TCL_Z_MODIFIER "u to %" TCL_Z_MODIFIER "u catch %" TCL_Z_MODIFIER "u",
"catch", rangePtr->nestingLevel, rangePtr->codeOffset,
rangePtr->codeOffset + rangePtr->numCodeBytes - 1,
rangePtr->catchOffset));
break;
}
}
|
| ︙ | ︙ | |||
1174 1175 1176 1177 1178 1179 1180 |
TclNewObj(commands);
codeOffPtr = codePtr->codeDeltaStart;
codeLenPtr = codePtr->codeLengthStart;
srcOffPtr = codePtr->srcDeltaStart;
srcLenPtr = codePtr->srcLengthStart;
codeOffset = sourceOffset = 0;
| | | 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 |
TclNewObj(commands);
codeOffPtr = codePtr->codeDeltaStart;
codeLenPtr = codePtr->codeLengthStart;
srcOffPtr = codePtr->srcDeltaStart;
srcLenPtr = codePtr->srcLengthStart;
codeOffset = sourceOffset = 0;
for (i=0 ; i<(int)codePtr->numCommands ; i++) {
Tcl_Obj *cmd;
codeOffset += Decode(codeOffPtr);
codeLength = Decode(codeLenPtr);
sourceOffset += Decode(srcOffPtr);
sourceLength = Decode(srcLenPtr);
TclNewObj(cmd);
|
| ︙ | ︙ | |||
1262 1263 1264 1265 1266 1267 1268 | * in order to disassemble them. * *---------------------------------------------------------------------- */ int Tcl_DisassembleObjCmd( | | | 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 |
* in order to disassemble them.
*
*----------------------------------------------------------------------
*/
int
Tcl_DisassembleObjCmd(
void *clientData, /* What type of operation. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const types[] = {
"constructor", "destructor",
"lambda", "method", "objmethod", "proc", "script", NULL
|
| ︙ | ︙ | |||
1522 1523 1524 1525 1526 1527 1528 | Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not a class", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", TclGetString(objv[2]), NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, | | | | 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods,
objv[3]);
goto methodBody;
case DISAS_OBJECT_METHOD:
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "objectName methodName");
return TCL_ERROR;
}
/*
* Look up the body of an instance method.
*/
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (oPtr->methodsPtr == NULL) {
goto unknownMethod;
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[3]);
/*
* Compile (if necessary) and disassemble a method body.
*/
methodBody:
if (hPtr == NULL) {
|
| ︙ | ︙ |
Changes to generic/tclEncoding.c.
| ︙ | ︙ | |||
364 365 366 367 368 369 370 |
*----------------------------------------------------------------------
*/
int
Tcl_SetEncodingSearchPath(
Tcl_Obj *searchPath)
{
| | | | 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 |
*----------------------------------------------------------------------
*/
int
Tcl_SetEncodingSearchPath(
Tcl_Obj *searchPath)
{
size_t dummy;
if (TCL_ERROR == TclListObjLengthM(NULL, searchPath, &dummy)) {
return TCL_ERROR;
}
TclSetProcessGlobalValue(&encodingSearchPath, searchPath, NULL);
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
411 412 413 414 415 416 417 |
*----------------------------------------------------------------------
*/
void
TclSetLibraryPath(
Tcl_Obj *path)
{
| | | | 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 |
*----------------------------------------------------------------------
*/
void
TclSetLibraryPath(
Tcl_Obj *path)
{
size_t dummy;
if (TCL_ERROR == TclListObjLengthM(NULL, path, &dummy)) {
return;
}
TclSetProcessGlobalValue(&libraryPath, path, NULL);
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
447 448 449 450 451 452 453 |
*
*---------------------------------------------------------------------------
*/
static void
FillEncodingFileMap(void)
{
| | | | | | | 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 479 480 481 482 483 484 485 486 487 488 489 490 |
*
*---------------------------------------------------------------------------
*/
static void
FillEncodingFileMap(void)
{
size_t i, numDirs = 0;
Tcl_Obj *map, *searchPath;
searchPath = Tcl_GetEncodingSearchPath();
Tcl_IncrRefCount(searchPath);
TclListObjLengthM(NULL, searchPath, &numDirs);
map = Tcl_NewDictObj();
Tcl_IncrRefCount(map);
for (i = numDirs-1; i != TCL_INDEX_NONE; i--) {
/*
* Iterate backwards through the search path so as we overwrite
* entries found, we favor files earlier on the search path.
*/
size_t j, numFiles;
Tcl_Obj *directory, *matchFileList;
Tcl_Obj **filev;
Tcl_GlobTypeData readableFiles = {
TCL_GLOB_TYPE_FILE, TCL_GLOB_PERM_R, NULL, NULL
};
TclNewObj(matchFileList);
Tcl_ListObjIndex(NULL, searchPath, i, &directory);
Tcl_IncrRefCount(directory);
Tcl_IncrRefCount(matchFileList);
Tcl_FSMatchInDirectory(NULL, matchFileList, directory, "*.enc",
&readableFiles);
TclListObjGetElementsM(NULL, matchFileList, &numFiles, &filev);
for (j=0; j<numFiles; j++) {
Tcl_Obj *encodingName, *fileObj;
fileObj = TclPathPart(NULL, filev[j], TCL_PATH_TAIL);
encodingName = TclPathPart(NULL, fileObj, TCL_PATH_ROOT);
Tcl_DictObjPut(NULL, map, encodingName, directory);
Tcl_DecrRefCount(fileObj);
|
| ︙ | ︙ | |||
1549 1550 1551 1552 1553 1554 1555 |
{
Tcl_Obj *nameObj = Tcl_NewStringObj(name, -1);
Tcl_Obj *fileNameObj = Tcl_DuplicateObj(nameObj);
Tcl_Obj *searchPath = Tcl_DuplicateObj(Tcl_GetEncodingSearchPath());
Tcl_Obj *map = TclGetProcessGlobalValue(&encodingFileMap);
Tcl_Obj **dir, *path, *directory = NULL;
Tcl_Channel chan = NULL;
| | | | 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 |
{
Tcl_Obj *nameObj = Tcl_NewStringObj(name, -1);
Tcl_Obj *fileNameObj = Tcl_DuplicateObj(nameObj);
Tcl_Obj *searchPath = Tcl_DuplicateObj(Tcl_GetEncodingSearchPath());
Tcl_Obj *map = TclGetProcessGlobalValue(&encodingFileMap);
Tcl_Obj **dir, *path, *directory = NULL;
Tcl_Channel chan = NULL;
size_t i, numDirs;
TclListObjGetElementsM(NULL, searchPath, &numDirs, &dir);
Tcl_IncrRefCount(nameObj);
Tcl_AppendToObj(fileNameObj, ".enc", -1);
Tcl_IncrRefCount(fileNameObj);
Tcl_DictObjGet(NULL, map, nameObj, &directory);
/*
* Check that any cached directory is still on the encoding search path.
|
| ︙ | ︙ | |||
2050 2051 2052 2053 2054 2055 2056 |
Tcl_EncodingType type;
init[0] = '\0';
final[0] = '\0';
Tcl_DStringInit(&escapeData);
while (1) {
| | | 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 |
Tcl_EncodingType type;
init[0] = '\0';
final[0] = '\0';
Tcl_DStringInit(&escapeData);
while (1) {
size_t argc;
const char **argv;
char *line;
Tcl_DString lineString;
Tcl_DStringInit(&lineString);
if (Tcl_Gets(chan, &lineString) == TCL_IO_FAILURE) {
break;
|
| ︙ | ︙ | |||
2312 2313 2314 2315 2316 2317 2318 |
} else {
char chbuf[2];
chbuf[0] = UCHAR(*src++); chbuf[1] = 0;
TclUtfToUCS4(chbuf, &ch);
}
dst += Tcl_UniCharToUtf(ch, dst);
} else {
| < > | > > > > > > | | < < < < > | 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 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 |
} else {
char chbuf[2];
chbuf[0] = UCHAR(*src++); chbuf[1] = 0;
TclUtfToUCS4(chbuf, &ch);
}
dst += Tcl_UniCharToUtf(ch, dst);
} else {
const char *saveSrc = src;
size_t len = TclUtfToUCS4(src, &ch);
if ((len < 2) && (ch != 0) && !(flags & TCL_ENCODING_NOCOMPLAIN)
&& (flags & TCL_ENCODING_MODIFIED)) {
result = TCL_CONVERT_SYNTAX;
break;
}
src += len;
if (!(flags & TCL_ENCODING_UTF) && (ch > 0x3FF)) {
if (ch > 0xFFFF) {
/* CESU-8 6-byte sequence for chars > U+FFFF */
ch -= 0x10000;
*dst++ = 0xED;
*dst++ = (char) (((ch >> 16) & 0x0F) | 0xA0);
*dst++ = (char) (((ch >> 10) & 0x3F) | 0x80);
ch = (ch & 0x0CFF) | 0xDC00;
}
#if TCL_UTF_MAX < 4
cesu8:
#endif
*dst++ = (char) (((ch >> 12) | 0xE0) & 0xEF);
*dst++ = (char) (((ch >> 6) | 0x80) & 0xBF);
*dst++ = (char) ((ch | 0x80) & 0xBF);
continue;
#if TCL_UTF_MAX < 4
} else if ((ch | 0x7FF) == 0xDFFF) {
/*
* A surrogate character is detected, handle especially.
*/
int low = ch;
len = (src <= srcEnd-3) ? TclUtfToUCS4(src, &low) : 0;
if (((low & ~0x3FF) != 0xDC00) || (ch & 0x400)) {
if (!(flags & TCL_ENCODING_NOCOMPLAIN)) {
result = TCL_CONVERT_UNKNOWN;
src = saveSrc;
break;
}
goto cesu8;
}
src += len;
dst += Tcl_UniCharToUtf(ch, dst);
ch = low;
#endif
} else if (!Tcl_UniCharIsUnicode(ch)) {
if (!(flags & TCL_ENCODING_NOCOMPLAIN)) {
result = TCL_CONVERT_UNKNOWN;
src = saveSrc;
break;
}
if (!(flags & TCL_ENCODING_MODIFIED)) {
|
| ︙ | ︙ | |||
2663 2664 2665 2666 2667 2668 2669 |
* Special case for 1-byte utf chars for speed. Make sure we work with
* unsigned short-size data.
*/
if (ch && ch < 0x80) {
*dst++ = (ch & 0xFF);
} else {
| | | 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 |
* Special case for 1-byte utf chars for speed. Make sure we work with
* unsigned short-size data.
*/
if (ch && ch < 0x80) {
*dst++ = (ch & 0xFF);
} else {
dst += Tcl_UniCharToUtf(ch | TCL_COMBINE, dst);
}
src += sizeof(unsigned short);
}
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
|
| ︙ | ︙ | |||
3926 3927 3928 3929 3930 3931 3932 |
static void
InitializeEncodingSearchPath(
char **valuePtr,
size_t *lengthPtr,
Tcl_Encoding *encodingPtr)
{
const char *bytes;
| | | | 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 |
static void
InitializeEncodingSearchPath(
char **valuePtr,
size_t *lengthPtr,
Tcl_Encoding *encodingPtr)
{
const char *bytes;
size_t i, numDirs;
size_t numBytes;
Tcl_Obj *libPathObj, *encodingObj, *searchPathObj;
TclNewLiteralStringObj(encodingObj, "encoding");
TclNewObj(searchPathObj);
Tcl_IncrRefCount(encodingObj);
Tcl_IncrRefCount(searchPathObj);
libPathObj = TclGetLibraryPath();
Tcl_IncrRefCount(libPathObj);
TclListObjLengthM(NULL, libPathObj, &numDirs);
for (i = 0; i < numDirs; i++) {
Tcl_Obj *directoryObj, *pathObj;
Tcl_StatBuf stat;
Tcl_ListObjIndex(NULL, libPathObj, i, &directoryObj);
pathObj = Tcl_FSJoinToPath(directoryObj, 1, &encodingObj);
|
| ︙ | ︙ |
Changes to generic/tclEnsemble.c.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 | * Declarations for functions local to this file: */ static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr); static inline int EnsembleUnknownCallback(Tcl_Interp *interp, EnsembleConfig *ensemblePtr, int objc, Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr); | | | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | * Declarations for functions local to this file: */ static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr); static inline int EnsembleUnknownCallback(Tcl_Interp *interp, EnsembleConfig *ensemblePtr, int objc, Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr); static int NsEnsembleImplementationCmdNR(void *clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr); static int NsEnsembleStringOrder(const void *strPtr1, const void *strPtr2); static void DeleteEnsembleConfig(void *clientData); static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr, EnsembleConfig *ensemblePtr, Tcl_HashEntry *hPtr, Tcl_Obj *fix); static void FreeEnsembleCmdRep(Tcl_Obj *objPtr); static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void CompileToInvokedCommand(Tcl_Interp *interp, Tcl_Parse *parsePtr, Tcl_Obj *replacements, |
| ︙ | ︙ | |||
184 185 186 187 188 189 190 |
"subcommand", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case ENS_CREATE: {
const char *name;
| > | | 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 |
"subcommand", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case ENS_CREATE: {
const char *name;
size_t len;
int allocatedMapFlag = 0;
/*
* Defaults
*/
Tcl_Obj *subcmdObj = NULL;
Tcl_Obj *mapObj = NULL;
int permitPrefix = 1;
Tcl_Obj *unknownObj = NULL;
|
| ︙ | ︙ | |||
230 231 232 233 234 235 236 |
}
switch (idx) {
case CRT_CMD:
name = TclGetString(objv[1]);
cxtPtr = nsPtr;
continue;
case CRT_SUBCMDS:
| | | | 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 |
}
switch (idx) {
case CRT_CMD:
name = TclGetString(objv[1]);
cxtPtr = nsPtr;
continue;
case CRT_SUBCMDS:
if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
subcmdObj = (len > 0 ? objv[1] : NULL);
continue;
case CRT_PARAM:
if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
paramObj = (len > 0 ? objv[1] : NULL);
continue;
|
| ︙ | ︙ | |||
269 270 271 272 273 274 275 |
mapObj = NULL;
continue;
}
do {
Tcl_Obj **listv;
const char *cmd;
| | | 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 |
mapObj = NULL;
continue;
}
do {
Tcl_Obj **listv;
const char *cmd;
if (TclListObjGetElementsM(interp, listObj, &len,
&listv) != TCL_OK) {
Tcl_DictObjDone(&search);
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
}
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
|
| ︙ | ︙ | |||
334 335 336 337 338 339 340 |
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
continue;
case CRT_UNKNOWN:
| | | 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 |
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
continue;
case CRT_UNKNOWN:
if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
unknownObj = (len > 0 ? objv[1] : NULL);
continue;
|
| ︙ | ︙ | |||
497 498 499 500 501 502 503 |
Tcl_NewStringObj(ensembleConfigOptions[CONF_UNKNOWN],-1));
Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj);
Tcl_ListObjAppendElement(NULL, resultObj,
(tmpObj != NULL) ? tmpObj : Tcl_NewObj());
Tcl_SetObjResult(interp, resultObj);
} else {
| > | | 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 |
Tcl_NewStringObj(ensembleConfigOptions[CONF_UNKNOWN],-1));
Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj);
Tcl_ListObjAppendElement(NULL, resultObj,
(tmpObj != NULL) ? tmpObj : Tcl_NewObj());
Tcl_SetObjResult(interp, resultObj);
} else {
size_t len;
int allocatedMapFlag = 0;
Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, *paramObj = NULL,
*unknownObj = NULL; /* Defaults, silence gcc 4 warnings */
int permitPrefix, flags = 0; /* silence gcc 4 warning */
Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj);
Tcl_GetEnsembleMappingDict(NULL, token, &mapObj);
Tcl_GetEnsembleParameterList(NULL, token, ¶mObj);
|
| ︙ | ︙ | |||
531 532 533 534 535 536 537 |
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
switch (idx) {
case CONF_SUBCMDS:
| | | | 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 |
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
switch (idx) {
case CONF_SUBCMDS:
if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) {
goto freeMapAndError;
}
subcmdObj = (len > 0 ? objv[1] : NULL);
continue;
case CONF_PARAM:
if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) {
goto freeMapAndError;
}
paramObj = (len > 0 ? objv[1] : NULL);
continue;
case CONF_MAP: {
Tcl_Obj *patchedDict = NULL, *subcmdWordsObj, **listv;
const char *cmd;
|
| ︙ | ︙ | |||
559 560 561 562 563 564 565 |
goto freeMapAndError;
}
if (done) {
mapObj = NULL;
continue;
}
do {
| | | 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 |
goto freeMapAndError;
}
if (done) {
mapObj = NULL;
continue;
}
do {
if (TclListObjGetElementsM(interp, listObj, &len,
&listv) != TCL_OK) {
Tcl_DictObjDone(&search);
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
}
goto freeMapAndError;
}
|
| ︙ | ︙ | |||
621 622 623 624 625 626 627 |
case CONF_PREFIX:
if (Tcl_GetBooleanFromObj(interp, objv[1],
&permitPrefix) != TCL_OK) {
goto freeMapAndError;
}
continue;
case CONF_UNKNOWN:
| | | 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 |
case CONF_PREFIX:
if (Tcl_GetBooleanFromObj(interp, objv[1],
&permitPrefix) != TCL_OK) {
goto freeMapAndError;
}
continue;
case CONF_UNKNOWN:
if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) {
goto freeMapAndError;
}
unknownObj = (len > 0 ? objv[1] : NULL);
continue;
}
}
|
| ︙ | ︙ | |||
788 789 790 791 792 793 794 |
if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
if (subcmdList != NULL) {
| | | | 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 |
if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
if (subcmdList != NULL) {
size_t length;
if (TclListObjLengthM(interp, subcmdList, &length) != TCL_OK) {
return TCL_ERROR;
}
if (length < 1) {
subcmdList = NULL;
}
}
|
| ︙ | ︙ | |||
855 856 857 858 859 860 861 |
Tcl_Interp *interp,
Tcl_Command token,
Tcl_Obj *paramList)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldList;
| | | | 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 |
Tcl_Interp *interp,
Tcl_Command token,
Tcl_Obj *paramList)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldList;
size_t length;
if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
if (paramList == NULL) {
length = 0;
} else {
if (TclListObjLengthM(interp, paramList, &length) != TCL_OK) {
return TCL_ERROR;
}
if (length < 1) {
paramList = NULL;
}
}
|
| ︙ | ︙ | |||
940 941 942 943 944 945 946 |
if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
if (mapDict != NULL) {
| > | | 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 |
if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
if (mapDict != NULL) {
size_t size;
int done;
Tcl_DictSearch search;
Tcl_Obj *valuePtr;
if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1039 1040 1041 1042 1043 1044 1045 |
if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
if (unknownList != NULL) {
| | | | 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 |
if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
if (unknownList != NULL) {
size_t length;
if (TclListObjLengthM(interp, unknownList, &length) != TCL_OK) {
return TCL_ERROR;
}
if (length < 1) {
unknownList = NULL;
}
}
|
| ︙ | ︙ | |||
1523 1524 1525 1526 1527 1528 1529 |
const EnsembleImplMap map[]) /* The subcommands to create */
{
Tcl_Command ensemble;
Tcl_Namespace *ns;
Tcl_DString buf, hiddenBuf;
const char **nameParts = NULL;
const char *cmdName = NULL;
| > | | 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 |
const EnsembleImplMap map[]) /* The subcommands to create */
{
Tcl_Command ensemble;
Tcl_Namespace *ns;
Tcl_DString buf, hiddenBuf;
const char **nameParts = NULL;
const char *cmdName = NULL;
size_t i, nameCount = 0;
int ensembleFlags = 0, hiddenLen;
/*
* Construct the path for the ensemble namespace and create it.
*/
Tcl_DStringInit(&buf);
Tcl_DStringInit(&hiddenBuf);
|
| ︙ | ︙ | |||
1674 1675 1676 1677 1678 1679 1680 | * placed in the interpreter's result. * *---------------------------------------------------------------------- */ int TclEnsembleImplementationCmd( | | | | 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 |
* placed in the interpreter's result.
*
*----------------------------------------------------------------------
*/
int
TclEnsembleImplementationCmd(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
return Tcl_NRCallObjProc(interp, NsEnsembleImplementationCmdNR,
clientData, objc, objv);
}
static int
NsEnsembleImplementationCmdNR(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData;
/* The ensemble itself. */
Tcl_Obj *prefixObj; /* An object containing the prefix words of
|
| ︙ | ︙ | |||
1882 1883 1884 1885 1886 1887 1888 |
* but don't do that because cacheing of the command object should help.
*/
{
Tcl_Obj *copyPtr; /* The list of words to dispatch on.
* Will be freed by the dispatch engine. */
Tcl_Obj **copyObjv;
| | | | 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 |
* but don't do that because cacheing of the command object should help.
*/
{
Tcl_Obj *copyPtr; /* The list of words to dispatch on.
* Will be freed by the dispatch engine. */
Tcl_Obj **copyObjv;
size_t copyObjc, prefixObjc;
TclListObjLengthM(NULL, prefixObj, &prefixObjc);
if (objc == 2) {
copyPtr = TclListObjCopy(NULL, prefixObj);
} else {
copyPtr = Tcl_NewListObj(objc - 2 + prefixObjc, NULL);
Tcl_ListObjAppendList(NULL, copyPtr, prefixObj);
Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
|
| ︙ | ︙ | |||
1918 1919 1920 1921 1922 1923 1924 | } /* * Hand off to the target command. */ TclSkipTailcall(interp); | | | 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 |
}
/*
* Hand off to the target command.
*/
TclSkipTailcall(interp);
TclListObjGetElementsM(NULL, copyPtr, ©Objc, ©Objv);
((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr;
return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL);
}
unknownOrAmbiguousSubcommand:
/*
* The named subcommand did not match any exported command. If there is a
|
| ︙ | ︙ | |||
1980 1981 1982 1983 1984 1985 1986 |
}
Tcl_SetObjResult(interp, errorObj);
return TCL_ERROR;
}
int
TclClearRootEnsemble(
| | | 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 |
}
Tcl_SetObjResult(interp, errorObj);
return TCL_ERROR;
}
int
TclClearRootEnsemble(
TCL_UNUSED(void **),
Tcl_Interp *interp,
int result)
{
TclResetRewriteEnsemble(interp, 1);
return result;
}
|
| ︙ | ︙ | |||
2086 2087 2088 2089 2090 2091 2092 | * Can create an alternative ensemble rewrite structure. * *---------------------------------------------------------------------- */ static int FreeER( | | | | 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 |
* Can create an alternative ensemble rewrite structure.
*
*----------------------------------------------------------------------
*/
static int
FreeER(
void *data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
Tcl_Obj **tmp = (Tcl_Obj **) data[0];
Tcl_Obj **store = (Tcl_Obj **) data[1];
Tcl_Free(store);
Tcl_Free(tmp);
return result;
}
void
TclSpellFix(
Tcl_Interp *interp,
Tcl_Obj *const *objv,
size_t objc,
size_t badIdx,
Tcl_Obj *bad,
Tcl_Obj *fix)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *const *search;
Tcl_Obj **store;
|
| ︙ | ︙ | |||
2227 2228 2229 2230 2231 2232 2233 |
*----------------------------------------------------------------------
*/
Tcl_Obj *const *
TclFetchEnsembleRoot(
Tcl_Interp *interp,
Tcl_Obj *const *objv,
| | | | 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 |
*----------------------------------------------------------------------
*/
Tcl_Obj *const *
TclFetchEnsembleRoot(
Tcl_Interp *interp,
Tcl_Obj *const *objv,
size_t objc,
size_t *objcPtr)
{
Tcl_Obj *const *sourceObjs;
Interp *iPtr = (Interp *) interp;
if (iPtr->ensembleRewrite.sourceObjs) {
*objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs
- iPtr->ensembleRewrite.numInsertedObjs;
|
| ︙ | ︙ | |||
2278 2279 2280 2281 2282 2283 2284 |
EnsembleUnknownCallback(
Tcl_Interp *interp,
EnsembleConfig *ensemblePtr,
int objc,
Tcl_Obj *const objv[],
Tcl_Obj **prefixObjPtr)
{
| > > | | | | 2282 2283 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 |
EnsembleUnknownCallback(
Tcl_Interp *interp,
EnsembleConfig *ensemblePtr,
int objc,
Tcl_Obj *const objv[],
Tcl_Obj **prefixObjPtr)
{
size_t paramc;
int result;
size_t i, prefixObjc;
Tcl_Obj **paramv, *unknownCmd, *ensObj;
/*
* Create the "unknown" command callback to determine what to do.
*/
unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler);
TclNewObj(ensObj);
Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj);
Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj);
for (i = 1 ; i < (size_t)objc ; i++) {
Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]);
}
TclListObjGetElementsM(NULL, unknownCmd, ¶mc, ¶mv);
Tcl_IncrRefCount(unknownCmd);
/*
* Call the "unknown" handler. No attempt to NRE-enable this as deep
* recursion through unknown handlers is perverse. It is always an error
* for an unknown handler to delete its ensemble. Don't do that.
*/
|
| ︙ | ︙ | |||
2329 2330 2331 2332 2333 2334 2335 | *prefixObjPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(*prefixObjPtr); TclDecrRefCount(unknownCmd); Tcl_ResetResult(interp); /* A non-empty list is the replacement command. */ | | | 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 |
*prefixObjPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(*prefixObjPtr);
TclDecrRefCount(unknownCmd);
Tcl_ResetResult(interp);
/* A non-empty list is the replacement command. */
if (TclListObjLengthM(interp, *prefixObjPtr, &prefixObjc) != TCL_OK) {
TclDecrRefCount(*prefixObjPtr);
Tcl_AddErrorInfo(interp, "\n while parsing result of "
"ensemble unknown subcommand handler");
return TCL_ERROR;
}
if (prefixObjc > 0) {
return TCL_OK;
|
| ︙ | ︙ | |||
2481 2482 2483 2484 2485 2486 2487 |
Tcl_Free(ensemblePtr->subcommandArrayPtr);
}
Tcl_DeleteHashTable(hash);
}
static void
DeleteEnsembleConfig(
| | | 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 |
Tcl_Free(ensemblePtr->subcommandArrayPtr);
}
Tcl_DeleteHashTable(hash);
}
static void
DeleteEnsembleConfig(
void *clientData)
{
EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData;
Namespace *nsPtr = ensemblePtr->nsPtr;
/* Unlink from the ensemble chain if it not already marked as unlinked. */
if (ensemblePtr->next != ensemblePtr) {
|
| ︙ | ︙ | |||
2577 2578 2579 2580 2581 2582 2583 |
Tcl_Obj *mapDict = ensemblePtr->subcommandDict;
Tcl_Obj *subList = ensemblePtr->subcmdList;
ClearTable(ensemblePtr);
Tcl_InitHashTable(hash, TCL_STRING_KEYS);
if (subList) {
| | | | | 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 |
Tcl_Obj *mapDict = ensemblePtr->subcommandDict;
Tcl_Obj *subList = ensemblePtr->subcmdList;
ClearTable(ensemblePtr);
Tcl_InitHashTable(hash, TCL_STRING_KEYS);
if (subList) {
size_t subc;
Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj;
const char *name;
/*
* There is a list of exactly what subcommands go in the table.
* Determine the target for each.
*/
TclListObjGetElementsM(NULL, subList, &subc, &subv);
if (subList == mapDict) {
/*
* Unusual case where explicit list of subcommands is same value
* as the dict mapping to targets.
*/
for (i = 0; i < subc; i += 2) {
name = TclGetString(subv[i]);
hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
if (!isNew) {
cmdObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
Tcl_DecrRefCount(cmdObj);
}
Tcl_SetHashValue(hPtr, subv[i+1]);
|
| ︙ | ︙ | |||
2617 2618 2619 2620 2621 2622 2623 |
}
}
} else {
/*
* Usual case where we can freely act on the list and dict.
*/
| | | 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 |
}
}
} else {
/*
* Usual case where we can freely act on the list and dict.
*/
for (i = 0; i < subc; i++) {
name = TclGetString(subv[i]);
hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
if (!isNew) {
continue;
}
/*
|
| ︙ | ︙ | |||
2907 2908 2909 2910 2911 2912 2913 |
{
DefineLineInformation;
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
Tcl_Obj *replaced, *replacement;
Tcl_Command ensemble = (Tcl_Command) cmdPtr;
Command *oldCmdPtr = cmdPtr, *newCmdPtr;
| | | | | 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 |
{
DefineLineInformation;
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
Tcl_Obj *replaced, *replacement;
Tcl_Command ensemble = (Tcl_Command) cmdPtr;
Command *oldCmdPtr = cmdPtr, *newCmdPtr;
int result, flags = 0, depth = 1, invokeAnyway = 0;
int ourResult = TCL_ERROR;
size_t i, len, numBytes;
const char *word;
TclNewObj(replaced);
Tcl_IncrRefCount(replaced);
if ((int)parsePtr->numWords <= depth) {
goto failed;
}
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
/*
* Too hard.
*/
|
| ︙ | ︙ | |||
2983 2984 2985 2986 2987 2988 2989 |
(void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj);
if (listObj != NULL) {
size_t sclen;
const char *str;
Tcl_Obj *matchObj = NULL;
| | | 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 |
(void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj);
if (listObj != NULL) {
size_t sclen;
const char *str;
Tcl_Obj *matchObj = NULL;
if (TclListObjGetElementsM(NULL, listObj, &len, &elems) != TCL_OK) {
goto failed;
}
for (i=0 ; i<len ; i++) {
str = Tcl_GetStringFromObj(elems[i], &sclen);
if ((sclen == numBytes) && !memcmp(word, str, numBytes)) {
/*
* Exact match! Excellent!
|
| ︙ | ︙ | |||
3103 3104 3105 3106 3107 3108 3109 |
* that we also reject dealing with multi-element rewrites if we are in a
* safe interpreter, as there is otherwise a (highly gnarly!) way to make
* Tcl crash open to exploit.
*/
doneMapLookup:
Tcl_ListObjAppendElement(NULL, replaced, replacement);
| | | 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 |
* that we also reject dealing with multi-element rewrites if we are in a
* safe interpreter, as there is otherwise a (highly gnarly!) way to make
* Tcl crash open to exploit.
*/
doneMapLookup:
Tcl_ListObjAppendElement(NULL, replaced, replacement);
if (TclListObjGetElementsM(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
goto failed;
} else if (len != 1) {
/*
* Note that at this point we know we can't issue any special
* instruction sequence as the mapping isn't one that we support at
* the compiled level.
*/
|
| ︙ | ︙ | |||
3141 3142 3143 3144 3145 3146 3147 |
/*
* See whether we have a nested ensemble. If we do, we can go round the
* mulberry bush again, consuming the next word.
*/
if (cmdPtr->compileProc == TclCompileEnsemble) {
tokenPtr = TokenAfter(tokenPtr);
| | | 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 |
/*
* See whether we have a nested ensemble. If we do, we can go round the
* mulberry bush again, consuming the next word.
*/
if (cmdPtr->compileProc == TclCompileEnsemble) {
tokenPtr = TokenAfter(tokenPtr);
if ((int)parsePtr->numWords < depth + 1
|| tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
/*
* Too hard because the user has done something unpleasant like
* omitting the sub-ensemble's command name or used a non-constant
* name for a sub-ensemble's command name; we respond by bailing
* out completely (this is a rare case). [Bug 6d2f249a01]
*/
|
| ︙ | ︙ | |||
3174 3175 3176 3177 3178 3179 3180 |
goto cleanup;
}
/*
* Throw out any line information generated by the failed compile attempt.
*/
| | | 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 |
goto cleanup;
}
/*
* Throw out any line information generated by the failed compile attempt.
*/
while (mapPtr->nuloc > eclIndex + 1) {
mapPtr->nuloc--;
Tcl_Free(mapPtr->loc[mapPtr->nuloc].line);
mapPtr->loc[mapPtr->nuloc].line = NULL;
}
/*
* Reset the index of next command. Toss out any from failed nested
|
| ︙ | ︙ | |||
3236 3237 3238 3239 3240 3241 3242 |
return ourResult;
}
int
TclAttemptCompileProc(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
| | | > | | | | | 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 |
return ourResult;
}
int
TclAttemptCompileProc(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
size_t depth,
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation;
int result;
size_t i;
Tcl_Token *saveTokenPtr = parsePtr->tokenPtr;
size_t savedStackDepth = envPtr->currStackDepth;
unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
size_t savedAuxDataArrayNext = envPtr->auxDataArrayNext;
size_t savedExceptArrayNext = envPtr->exceptArrayNext;
#ifdef TCL_COMPILE_DEBUG
size_t savedExceptDepth = envPtr->exceptDepth;
#endif
if (cmdPtr->compileProc == NULL) {
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
3307 3308 3309 3310 3311 3312 3313 |
}
#endif
if (result != TCL_OK) {
ExceptionAux *auxPtr = envPtr->exceptAuxArrayPtr;
for (i = 0; i < savedExceptArrayNext; i++) {
| | | | 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 |
}
#endif
if (result != TCL_OK) {
ExceptionAux *auxPtr = envPtr->exceptAuxArrayPtr;
for (i = 0; i < savedExceptArrayNext; i++) {
while ((int)auxPtr->numBreakTargets > 0
&& auxPtr->breakTargets[auxPtr->numBreakTargets - 1]
>= savedCodeNext) {
auxPtr->numBreakTargets--;
}
while ((int)auxPtr->numContinueTargets > 0
&& auxPtr->continueTargets[auxPtr->numContinueTargets - 1]
>= savedCodeNext) {
auxPtr->numContinueTargets--;
}
auxPtr++;
}
envPtr->exceptArrayNext = savedExceptArrayNext;
|
| ︙ | ︙ | |||
3377 3378 3379 3380 3381 3382 3383 |
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation;
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
const char *bytes;
| | | | | | 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 |
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation;
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
const char *bytes;
int cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
size_t i, numWords, length;
/*
* Push the words of the command. Take care; the command words may be
* scripts that have backslashes in them, and [info frame 0] can see the
* difference. Hence the call to TclContinuationsEnterDerived...
*/
TclListObjGetElementsM(NULL, replacements, &numWords, &words);
for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords;
i++, tokPtr = TokenAfter(tokPtr)) {
if (i > 0 && i <= numWords) {
bytes = Tcl_GetStringFromObj(words[i-1], &length);
PushLiteral(envPtr, bytes, length);
continue;
}
SetLineInformation(i);
if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) {
|
| ︙ | ︙ | |||
3680 3681 3682 3683 3684 3685 3686 |
{
/*
* Verify that the number of arguments is correct; that's the only case
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
* which is the only code that sees the shenanigans of ensemble dispatch.
*/
| | | 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 |
{
/*
* Verify that the number of arguments is correct; that's the only case
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
* which is the only code that sees the shenanigans of ensemble dispatch.
*/
if ((int)parsePtr->numWords < 1) {
return TCL_ERROR;
}
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
}
int
|
| ︙ | ︙ | |||
3702 3703 3704 3705 3706 3707 3708 |
{
/*
* Verify that the number of arguments is correct; that's the only case
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
* which is the only code that sees the shenanigans of ensemble dispatch.
*/
| | | 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 |
{
/*
* Verify that the number of arguments is correct; that's the only case
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
* which is the only code that sees the shenanigans of ensemble dispatch.
*/
if ((int)parsePtr->numWords < 2) {
return TCL_ERROR;
}
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
}
int
|
| ︙ | ︙ | |||
3724 3725 3726 3727 3728 3729 3730 |
{
/*
* Verify that the number of arguments is correct; that's the only case
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
* which is the only code that sees the shenanigans of ensemble dispatch.
*/
| | | 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 |
{
/*
* Verify that the number of arguments is correct; that's the only case
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
* which is the only code that sees the shenanigans of ensemble dispatch.
*/
if ((int)parsePtr->numWords < 3) {
return TCL_ERROR;
}
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclEnv.c.
| ︙ | ︙ | |||
361 362 363 364 365 366 367 |
*/
Tcl_Free(p);
#endif /* HAVE_PUTENV_THAT_COPIES */
}
Tcl_MutexUnlock(&envMutex);
| < < < < < < < < < | 361 362 363 364 365 366 367 368 369 370 371 372 373 374 |
*/
Tcl_Free(p);
#endif /* HAVE_PUTENV_THAT_COPIES */
}
Tcl_MutexUnlock(&envMutex);
}
/*
*----------------------------------------------------------------------
*
* Tcl_PutEnv --
*
|
| ︙ | ︙ | |||
624 625 626 627 628 629 630 | * this happens because the whole interpreter is being deleted). * *---------------------------------------------------------------------- */ static char * EnvTraceProc( | | | 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 |
* this happens because the whole interpreter is being deleted).
*
*----------------------------------------------------------------------
*/
static char *
EnvTraceProc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter whose "env" variable is being
* modified. */
const char *name1, /* Better be "env". */
const char *name2, /* Name of variable being modified, or NULL if
* whole array is being deleted (UTF-8). */
int flags) /* Indicates what's happening. */
{
|
| ︙ | ︙ |
Changes to generic/tclEvent.c.
| ︙ | ︙ | |||
203 204 205 206 207 208 209 |
* Tcl_SaveInterpState call before calling something like Tcl_DoOneEvent()
* that could lead us here.
*/
Tcl_Preserve(assocPtr);
Tcl_Preserve(interp);
while (assocPtr->firstBgPtr != NULL) {
| | > | | 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 |
* Tcl_SaveInterpState call before calling something like Tcl_DoOneEvent()
* that could lead us here.
*/
Tcl_Preserve(assocPtr);
Tcl_Preserve(interp);
while (assocPtr->firstBgPtr != NULL) {
int code;
size_t prefixObjc;
Tcl_Obj **prefixObjv, **tempObjv;
/*
* Note we copy the handler command prefix each pass through, so we do
* support one handler setting another handler.
*/
Tcl_Obj *copyObj = TclListObjCopy(NULL, assocPtr->cmdPrefix);
errPtr = assocPtr->firstBgPtr;
TclListObjGetElementsM(NULL, copyObj, &prefixObjc, &prefixObjv);
tempObjv = (Tcl_Obj**)Tcl_Alloc((prefixObjc+2) * sizeof(Tcl_Obj *));
memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *));
tempObjv[prefixObjc] = errPtr->errorMsg;
tempObjv[prefixObjc+1] = errPtr->returnOpts;
Tcl_AllowExceptions(interp);
code = Tcl_EvalObjv(interp, prefixObjc+2, tempObjv, TCL_EVAL_GLOBAL);
|
| ︙ | ︙ |
Changes to generic/tclExecute.c.
| ︙ | ︙ | |||
107 108 109 110 111 112 113 |
* Helpers for NR - non-recursive calls to TEBC
* Minimal data required to fully reconstruct the execution state.
*/
typedef struct {
ByteCode *codePtr; /* Constant until the BC returns */
/* -----------------------------------------*/
| | | | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 |
* Helpers for NR - non-recursive calls to TEBC
* Minimal data required to fully reconstruct the execution state.
*/
typedef struct {
ByteCode *codePtr; /* Constant until the BC returns */
/* -----------------------------------------*/
Tcl_Obj **catchTop; /* These fields are used on return TO this */
Tcl_Obj *auxObjList; /* this level: they record the state when a */
CmdFrame cmdFrame; /* new codePtr was received for NR */
/* execution. */
Tcl_Obj *stack[1]; /* Start of the actual combined catch and obj
* stacks; the struct will be expanded as
* necessary */
} TEBCdata;
#define TEBC_YIELD() \
do { \
esPtr->tosPtr = tosPtr; \
|
| ︙ | ︙ | |||
362 363 364 365 366 367 368 | #define OBJ_AT_TOS *tosPtr #define OBJ_UNDER_TOS *(tosPtr-1) #define OBJ_AT_DEPTH(n) *(tosPtr-(n)) | | | | | | | | | 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 |
#define OBJ_AT_TOS *tosPtr
#define OBJ_UNDER_TOS *(tosPtr-1)
#define OBJ_AT_DEPTH(n) *(tosPtr-(n))
#define CURR_DEPTH ((size_t)(tosPtr - initTosPtr))
#define STACK_BASE(esPtr) ((esPtr)->stackWords - 1)
/*
* Macros used to trace instruction execution. The macros TRACE,
* TRACE_WITH_OBJ, and O2S are only used inside TclNRExecuteByteCode. O2S is
* only used in TRACE* calls to get a string from an object.
*/
#ifdef TCL_COMPILE_DEBUG
# define TRACE(a) \
while (traceInstructions) { \
fprintf(stdout, "%2" TCL_Z_MODIFIER "u: %2" TCL_Z_MODIFIER "u (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \
CURR_DEPTH, \
(size_t)(pc - codePtr->codeStart), \
GetOpcodeName(pc)); \
printf a; \
break; \
}
# define TRACE_APPEND(a) \
while (traceInstructions) { \
printf a; \
break; \
}
# define TRACE_ERROR(interp) \
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
# define TRACE_WITH_OBJ(a, objPtr) \
while (traceInstructions) { \
fprintf(stdout, "%2" TCL_Z_MODIFIER "u: %2" TCL_Z_MODIFIER "u (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \
CURR_DEPTH, \
(size_t)(pc - codePtr->codeStart), \
GetOpcodeName(pc)); \
printf a; \
TclPrintObject(stdout, objPtr, 30); \
fprintf(stdout, "\n"); \
break; \
}
# define O2S(objPtr) \
|
| ︙ | ︙ | |||
616 617 618 619 620 621 622 | Tcl_Obj *const objv[]); #endif /* TCL_COMPILE_STATS */ #ifdef TCL_COMPILE_DEBUG static const char * GetOpcodeName(const unsigned char *pc); static void PrintByteCodeInfo(ByteCode *codePtr); static const char * StringForResultCode(int result); static void ValidatePcAndStackTop(ByteCode *codePtr, | | | | 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 | Tcl_Obj *const objv[]); #endif /* TCL_COMPILE_STATS */ #ifdef TCL_COMPILE_DEBUG static const char * GetOpcodeName(const unsigned char *pc); static void PrintByteCodeInfo(ByteCode *codePtr); static const char * StringForResultCode(int result); static void ValidatePcAndStackTop(ByteCode *codePtr, const unsigned char *pc, size_t stackTop, int checkStack); #endif /* TCL_COMPILE_DEBUG */ static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); static void DeleteExecStack(ExecStack *esPtr); static void DupExprCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static Tcl_Obj * ExecuteExtendedBinaryMathOp(Tcl_Interp *interp, int opcode, Tcl_Obj **constants, Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); static Tcl_Obj * ExecuteExtendedUnaryMathOp(int opcode, Tcl_Obj *valuePtr); static void FreeExprCodeInternalRep(Tcl_Obj *objPtr); static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, int searchMode, ByteCode *codePtr); static const char * GetSrcInfoForPc(const unsigned char *pc, ByteCode *codePtr, size_t *lengthPtr, const unsigned char **pcBeg, int *cmdIdxPtr); static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, size_t growth, int move); static void IllegalExprOperandType(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj *opndPtr); static void InitByteCodeExecution(Tcl_Interp *interp); static inline int wordSkip(void *ptr); static void ReleaseDictIterator(Tcl_Obj *objPtr); /* Useful elsewhere, make available in tclInt.h or stubs? */ |
| ︙ | ︙ | |||
971 972 973 974 975 976 977 |
*----------------------------------------------------------------------
*/
static Tcl_Obj **
GrowEvaluationStack(
ExecEnv *eePtr, /* Points to the ExecEnv with an evaluation
* stack to enlarge. */
| | > | 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 |
*----------------------------------------------------------------------
*/
static Tcl_Obj **
GrowEvaluationStack(
ExecEnv *eePtr, /* Points to the ExecEnv with an evaluation
* stack to enlarge. */
size_t growth1, /* How much larger than the current used
* size. */
int move) /* 1 if move words since last marker. */
{
ExecStack *esPtr = eePtr->execStackPtr, *oldPtr = NULL;
size_t newBytes;
int growth = growth1;
int newElems, currElems, needed = growth - (esPtr->endPtr - esPtr->tosPtr);
Tcl_Obj **markerPtr = esPtr->markerPtr, **memStart;
int moveWords = 0;
if (move) {
if (!markerPtr) {
Tcl_Panic("STACK: Reallocating with no previous alloc");
|
| ︙ | ︙ | |||
1675 1676 1677 1678 1679 1680 1681 | */ Tcl_DecrRefCount(ctxCopyPtr->data.eval.path); ctxCopyPtr->data.eval.path = NULL; } } | | | 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 |
*/
Tcl_DecrRefCount(ctxCopyPtr->data.eval.path);
ctxCopyPtr->data.eval.path = NULL;
}
}
if ((size_t)word < ctxCopyPtr->nline) {
/*
* Note: We do not care if the line[word] is -1. This is a
* difference and requires a recompile (location changed from
* absolute to relative, literal is used fixed and through
* variable)
*
* Example:
|
| ︙ | ︙ | |||
1873 1874 1875 1876 1877 1878 1879 | * * Side effects: * Almost certainly, depending on the ByteCode's instructions. * *---------------------------------------------------------------------- */ #define bcFramePtr (&TD->cmdFrame) | | | | | | 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 |
*
* Side effects:
* Almost certainly, depending on the ByteCode's instructions.
*
*----------------------------------------------------------------------
*/
#define bcFramePtr (&TD->cmdFrame)
#define initCatchTop (TD->stack-1)
#define initTosPtr (initCatchTop+codePtr->maxExceptDepth)
#define esPtr (iPtr->execEnvPtr->execStackPtr)
int
TclNRExecuteByteCode(
Tcl_Interp *interp, /* Token for command interpreter. */
ByteCode *codePtr) /* The bytecode sequence to interpret. */
{
Interp *iPtr = (Interp *) interp;
TEBCdata *TD;
size_t size = sizeof(TEBCdata) - 1
+ (codePtr->maxStackDepth + codePtr->maxExceptDepth)
* sizeof(void *);
size_t numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *);
TclPreserveByteCode(codePtr);
/*
* Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame
*
* The execution uses a unified stack: first a TEBCdata, immediately
|
| ︙ | ︙ | |||
1945 1946 1947 1948 1949 1950 1951 |
TclResetRewriteEnsemble(interp, 1);
/*
* Push the callback for bytecode execution
*/
TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL,
| | | 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 |
TclResetRewriteEnsemble(interp, 1);
/*
* Push the callback for bytecode execution
*/
TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL,
/* cleanup */ NULL, INT2PTR(iPtr->evalFlags));
/*
* Reset discard result flag - because it is applicable for this call only,
* and should not affect all the nested invocations may return result.
*/
iPtr->evalFlags &= ~TCL_EVAL_DISCARD_RESULT;
|
| ︙ | ︙ | |||
2044 2045 2046 2047 2048 2049 2050 |
* Locals - variables that are used within opcodes or bounded sections of
* the file (jumps between opcodes within a family).
* NOTE: These are now mostly defined locally where needed.
*/
Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr;
Tcl_Obj **objv = NULL;
| | | | | 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 |
* Locals - variables that are used within opcodes or bounded sections of
* the file (jumps between opcodes within a family).
* NOTE: These are now mostly defined locally where needed.
*/
Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr;
Tcl_Obj **objv = NULL;
size_t length, objc = 0;
int opnd, pcAdjustment;
Var *varPtr, *arrayPtr;
#ifdef TCL_COMPILE_DEBUG
char cmdNameBuf[21];
#endif
#ifdef TCL_COMPILE_DEBUG
int starting = 1;
traceInstructions = (tclTraceExec == 3);
#endif
TEBC_DATA_DIG();
#ifdef TCL_COMPILE_DEBUG
if (!pc && (tclTraceExec >= 2)) {
PrintByteCodeInfo(codePtr);
fprintf(stdout, " Starting stack top=%" TCL_Z_MODIFIER "u\n", CURR_DEPTH);
fflush(stdout);
}
#endif
if (!pc) {
/* bytecode is starting from scratch */
pc = codePtr->codeStart;
|
| ︙ | ︙ | |||
2120 2121 2122 2123 2124 2125 2126 | } /* * Push the call's object result and continue execution with the next * instruction. */ | | | 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 |
}
/*
* Push the call's object result and continue execution with the next
* instruction.
*/
TRACE_WITH_OBJ(("%" TCL_Z_MODIFIER "u => ... after \"%.20s\": TCL_OK, result=",
objc, cmdNameBuf), Tcl_GetObjResult(interp));
/*
* Obtain and reset interp's result to avoid possible duplications of
* objects [Bug 781585]. We do not call Tcl_ResetResult to avoid any
* side effects caused by the resetting of errorInfo and errorCode
* [Bug 804681], which are not needed here. We chose instead to
|
| ︙ | ︙ | |||
2265 2266 2267 2268 2269 2270 2271 |
#ifdef TCL_COMPILE_DEBUG
/*
* Skip the stack depth check if an expansion is in progress.
*/
CHECK_STACK();
if (traceInstructions) {
| | | 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 |
#ifdef TCL_COMPILE_DEBUG
/*
* Skip the stack depth check if an expansion is in progress.
*/
CHECK_STACK();
if (traceInstructions) {
fprintf(stdout, "%2" TCL_Z_MODIFIER "u: %2" TCL_Z_MODIFIER "u ", iPtr->numLevels, CURR_DEPTH);
TclPrintInstruction(codePtr, pc);
fflush(stdout);
}
#endif /* TCL_COMPILE_DEBUG */
TCL_DTRACE_INST_NEXT();
|
| ︙ | ︙ | |||
2632 2633 2634 2635 2636 2637 2638 | * we do not define a special tclObjType for it. It is not dangerous * as the obj is never passed anywhere, so that all manipulations are * performed here and in INST_INVOKE_EXPANDED (in case of an expansion * error, also in INST_EXPAND_STKTOP). */ TclNewObj(objPtr); | | | | | | > | | > > > | < | | | | | 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 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 |
* we do not define a special tclObjType for it. It is not dangerous
* as the obj is never passed anywhere, so that all manipulations are
* performed here and in INST_INVOKE_EXPANDED (in case of an expansion
* error, also in INST_EXPAND_STKTOP).
*/
TclNewObj(objPtr);
objPtr->internalRep.twoPtrValue.ptr2 = UINT2PTR(CURR_DEPTH);
objPtr->length = 0;
PUSH_TAUX_OBJ(objPtr);
TRACE(("=> mark depth as %" TCL_Z_MODIFIER "u\n", CURR_DEPTH));
NEXT_INST_F(1, 0, 0);
break;
case INST_EXPAND_DROP:
/*
* Drops an element of the auxObjList, popping stack elements to
* restore the stack to the state before the point where the aux
* element was created.
*/
CLANG_ASSERT(auxObjList);
objc = CURR_DEPTH - PTR2UINT(auxObjList->internalRep.twoPtrValue.ptr2);
POP_TAUX_OBJ();
#ifdef TCL_COMPILE_DEBUG
/* Ugly abuse! */
starting = 1;
#endif
TRACE(("=> drop %" TCL_Z_MODIFIER "u items\n", objc));
NEXT_INST_V(1, objc, 0);
case INST_EXPAND_STKTOP: {
size_t i;
TEBCdata *newTD;
ptrdiff_t oldCatchTopOff, oldTosPtrOff;
/*
* Make sure that the element at stackTop is a list; if not, just
* leave with an error. Note that the element from the expand list
* will be removed at checkForCatch.
*/
objPtr = OBJ_AT_TOS;
TRACE(("\"%.30s\" => ", O2S(objPtr)));
if (TclListObjGetElementsM(interp, objPtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
(void) POP_OBJECT();
/*
* Make sure there is enough room in the stack to expand this list
* *and* process the rest of the command (at least up to the next
* argument expansion or command end). The operand is the current
* stack depth, as seen by the compiler.
*/
auxObjList->length += objc - 1;
if ((objc > 1) && (auxObjList->length > 0)) {
length = auxObjList->length /* Total expansion room we need */
+ codePtr->maxStackDepth /* Beyond the original max */
- CURR_DEPTH; /* Relative to where we are */
DECACHE_STACK_INFO();
oldCatchTopOff = catchTop - initCatchTop;
oldTosPtrOff = tosPtr - initTosPtr;
newTD = (TEBCdata *)
GrowEvaluationStack(iPtr->execEnvPtr, length, 1);
if (newTD != TD) {
/*
* Change the global data to point to the new stack: move the
* TEBCdataPtr TD, recompute the position of every other
* stack-allocated parameter, update the stack pointers.
*/
TD = newTD;
catchTop = initCatchTop + oldCatchTopOff;
tosPtr = initTosPtr + oldTosPtrOff;
}
}
/*
* Expand the list at stacktop onto the stack; free the list. Knowing
* that it has a freeIntRepProc we use Tcl_DecrRefCount().
*/
|
| ︙ | ︙ | |||
2745 2746 2747 2748 2749 2750 2751 | bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; cleanup = 1; pc += 1; /* yield next instruction */ TEBC_YIELD(); | | | | 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 |
bcFramePtr->data.tebc.pc = (char *) pc;
iPtr->cmdFramePtr = bcFramePtr;
cleanup = 1;
pc += 1;
/* yield next instruction */
TEBC_YIELD();
/* add TEBCResume for object at top of stack */
return TclNRExecuteByteCode(interp,
TclCompileObj(interp, OBJ_AT_TOS, NULL, 0));
case INST_INVOKE_EXPANDED:
CLANG_ASSERT(auxObjList);
objc = CURR_DEPTH - PTR2UINT(auxObjList->internalRep.twoPtrValue.ptr2);
POP_TAUX_OBJ();
if (objc) {
pcAdjustment = 1;
goto doInvocation;
}
/*
|
| ︙ | ︙ | |||
2781 2782 2783 2784 2785 2786 2787 |
doInvocation:
objv = &OBJ_AT_DEPTH(objc-1);
cleanup = objc;
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 2) {
| | | | 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 |
doInvocation:
objv = &OBJ_AT_DEPTH(objc-1);
cleanup = objc;
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 2) {
size_t i;
if (traceInstructions) {
strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
TRACE(("%" TCL_Z_MODIFIER "u => call ", objc));
} else {
fprintf(stdout, "%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels,
(size_t)(pc - codePtr->codeStart));
}
for (i = 0; i < objc; i++) {
TclPrintObject(stdout, objv[i], 15);
fprintf(stdout, " ");
|
| ︙ | ︙ | |||
2828 2829 2830 2831 2832 2833 2834 |
objc = TclGetUInt4AtPtr(pc+1);
opnd = TclGetUInt1AtPtr(pc+5);
objPtr = POP_OBJECT();
objv = &OBJ_AT_DEPTH(objc-1);
cleanup = objc;
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 2) {
| | | | | 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 |
objc = TclGetUInt4AtPtr(pc+1);
opnd = TclGetUInt1AtPtr(pc+5);
objPtr = POP_OBJECT();
objv = &OBJ_AT_DEPTH(objc-1);
cleanup = objc;
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 2) {
size_t i;
if (traceInstructions) {
strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
TRACE(("%" TCL_Z_MODIFIER "u => call (implementation %s) ", objc, O2S(objPtr)));
} else {
fprintf(stdout,
"%" TCL_Z_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking (using implementation %s) ",
iPtr->numLevels, (size_t)(pc - codePtr->codeStart),
O2S(objPtr));
}
for (i = 0; i < objc; i++) {
if (i < (size_t)opnd) {
fprintf(stdout, "<");
TclPrintObject(stdout, objv[i], 15);
fprintf(stdout, ">");
} else {
TclPrintObject(stdout, objv[i], 15);
}
fprintf(stdout, " ");
|
| ︙ | ︙ | |||
2878 2879 2880 2881 2882 2883 2884 | DECACHE_STACK_INFO(); pc += 6; TEBC_YIELD(); TclMarkTailcall(interp); TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); | | | 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 |
DECACHE_STACK_INFO();
pc += 6;
TEBC_YIELD();
TclMarkTailcall(interp);
TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
TclListObjGetElementsM(NULL, objPtr, &objc, &objv);
TclNRAddCallback(interp, TclNRReleaseValues, objPtr, NULL, NULL, NULL);
return TclNREvalObjv(interp, objc, objv, TCL_EVAL_INVOKE, NULL);
/*
* -----------------------------------------------------------------
* Start of INST_LOAD instructions.
*
|
| ︙ | ︙ | |||
3038 3039 3040 3041 3042 3043 3044 |
*
* WARNING: more 'goto' here than your doctor recommended! The different
* instructions set the value of some variables and then jump to somme
* common execution code.
*/
{
| | > | 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 |
*
* WARNING: more 'goto' here than your doctor recommended! The different
* instructions set the value of some variables and then jump to somme
* common execution code.
*/
{
int storeFlags;
size_t len;
case INST_STORE_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doStoreArrayDirect;
case INST_STORE_ARRAY1:
|
| ︙ | ︙ | |||
3289 3290 3291 3292 3293 3294 3295 |
varPtr = LOCAL(opnd);
cleanup = 1;
pcAdjustment = 5;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
| | | 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 |
varPtr = LOCAL(opnd);
cleanup = 1;
pcAdjustment = 5;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
if (TclListObjGetElementsM(interp, valuePtr, &objc, &objv)
!= TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
if (TclIsVarDirectReadable(varPtr)
&& TclIsVarDirectWritable(varPtr)) {
goto lappendListDirect;
|
| ︙ | ︙ | |||
3315 3316 3317 3318 3319 3320 3321 |
cleanup = 2;
pcAdjustment = 5;
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
TRACE(("%u \"%.30s\" \"%.30s\" => ",
opnd, O2S(part2Ptr), O2S(valuePtr)));
| | | 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 |
cleanup = 2;
pcAdjustment = 5;
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
TRACE(("%u \"%.30s\" \"%.30s\" => ",
opnd, O2S(part2Ptr), O2S(valuePtr)));
if (TclListObjGetElementsM(interp, valuePtr, &objc, &objv)
!= TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)
&& !WriteTraced(arrayPtr)) {
varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
|
| ︙ | ︙ | |||
3357 3358 3359 3360 3361 3362 3363 |
part2Ptr = NULL;
part1Ptr = OBJ_UNDER_TOS; /* variable name */
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(valuePtr)));
goto lappendList;
lappendListDirect:
objResultPtr = varPtr->value.objPtr;
| | | | | 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 |
part2Ptr = NULL;
part1Ptr = OBJ_UNDER_TOS; /* variable name */
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(valuePtr)));
goto lappendList;
lappendListDirect:
objResultPtr = varPtr->value.objPtr;
if (TclListObjLengthM(interp, objResultPtr, &len) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
if (Tcl_IsShared(objResultPtr)) {
Tcl_Obj *newValue = Tcl_DuplicateObj(objResultPtr);
TclDecrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr = newValue;
Tcl_IncrRefCount(newValue);
}
if (TclListObjAppendElements(interp, objResultPtr, objc, objv)
!= TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(pcAdjustment, cleanup, 1);
lappendList:
opnd = -1;
if (TclListObjGetElementsM(interp, valuePtr, &objc, &objv)
!= TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
DECACHE_STACK_INFO();
varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr,
TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr);
|
| ︙ | ︙ | |||
3416 3417 3418 3419 3420 3421 3422 |
{
int createdNewObj = 0;
Tcl_Obj *valueToAssign;
if (!objResultPtr) {
valueToAssign = valuePtr;
| | | | 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 |
{
int createdNewObj = 0;
Tcl_Obj *valueToAssign;
if (!objResultPtr) {
valueToAssign = valuePtr;
} else if (TclListObjLengthM(interp, objResultPtr, &len)!=TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
} else {
if (Tcl_IsShared(objResultPtr)) {
valueToAssign = Tcl_DuplicateObj(objResultPtr);
createdNewObj = 1;
} else {
valueToAssign = objResultPtr;
}
if (TclListObjAppendElements(interp, valueToAssign,
objc, objv) != TCL_OK) {
if (createdNewObj) {
TclDecrRefCount(valueToAssign);
}
goto errorInLappendListPtr;
}
}
|
| ︙ | ︙ | |||
4260 4261 4262 4263 4264 4265 4266 |
objResultPtr);
}
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
}
break;
case INST_INFO_LEVEL_NUM:
| | | | 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 |
objResultPtr);
}
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
}
break;
case INST_INFO_LEVEL_NUM:
TclNewIntObj(objResultPtr, (int)iPtr->varFramePtr->level);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
break;
case INST_INFO_LEVEL_ARGS: {
int level;
CallFrame *framePtr = iPtr->varFramePtr;
CallFrame *rootFramePtr = iPtr->rootFramePtr;
TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
if (TclGetIntFromObj(interp, OBJ_AT_TOS, &level) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
if (level <= 0) {
level += framePtr->level;
}
for (; ((int)framePtr->level!=level) && (framePtr!=rootFramePtr) ;
framePtr = framePtr->callerVarPtr) {
/* Empty loop body */
}
if (framePtr == rootFramePtr) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad level \"%s\"", TclGetString(OBJ_AT_TOS)));
TRACE_ERROR(interp);
|
| ︙ | ︙ | |||
4446 4447 4448 4449 4450 4451 4452 |
methodType = "destructor";
} else {
methodType = "method";
}
TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n",
O2S(valuePtr)));
| | | 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 |
methodType = "destructor";
} else {
methodType = "method";
}
TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n",
O2S(valuePtr)));
for (i = contextPtr->index ; i != TCL_INDEX_NONE ; i--) {
miPtr = contextPtr->callPtr->chain + i;
if (miPtr->isFilter
|| miPtr->mPtr->declaringClassPtr != classPtr) {
continue;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s implementation by \"%s\" not reachable from here",
|
| ︙ | ︙ | |||
4573 4574 4575 4576 4577 4578 4579 |
oPtr->flags &= ~FILTER_HANDLING;
}
{
Method *const mPtr =
contextPtr->callPtr->chain[newDepth].mPtr;
| > | > > > | 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 |
oPtr->flags &= ~FILTER_HANDLING;
}
{
Method *const mPtr =
contextPtr->callPtr->chain[newDepth].mPtr;
if (mPtr->typePtr->version < TCL_OO_METHOD_VERSION_2) {
return mPtr->typePtr->callProc(mPtr->clientData, interp,
(Tcl_ObjectContext) contextPtr, opnd, objv);
}
return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp,
(Tcl_ObjectContext) contextPtr, opnd, objv);
}
case INST_TCLOO_IS_OBJECT:
oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
objResultPtr = TCONST(oPtr != NULL ? 1 : 0);
TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr);
|
| ︙ | ︙ | |||
4633 4634 4635 4636 4637 4638 4639 |
opnd = TclGetUInt4AtPtr(pc+1);
objResultPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(5, opnd, 1);
case INST_LIST_LENGTH:
TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
| | | | | 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 |
opnd = TclGetUInt4AtPtr(pc+1);
objResultPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(5, opnd, 1);
case INST_LIST_LENGTH:
TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
if (TclListObjLengthM(interp, OBJ_AT_TOS, &length) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
TclNewIntObj(objResultPtr, length);
TRACE_APPEND(("%" TCL_Z_MODIFIER "u\n", length));
NEXT_INST_F(1, 1, 1);
case INST_LIST_INDEX: /* lindex with objc == 3 */
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
/*
* Extract the desired list element.
*/
if ((TclListObjGetElementsM(interp, valuePtr, &objc, &objv) == TCL_OK)
&& !TclHasInternalRep(value2Ptr, &tclListType)) {
int code;
DECACHE_STACK_INFO();
code = TclGetIntForIndexM(interp, value2Ptr, objc-1, &index);
CACHE_STACK_INFO();
if (code == TCL_OK) {
|
| ︙ | ︙ | |||
4695 4696 4697 4698 4699 4700 4701 |
TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd));
/*
* Get the contents of the list, making sure that it really is a list
* in the process.
*/
| | | 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 |
TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd));
/*
* Get the contents of the list, making sure that it really is a list
* in the process.
*/
if (TclListObjGetElementsM(interp, valuePtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
/* Decode end-offset index values. */
index = TclIndexDecode(opnd, objc - 1);
|
| ︙ | ︙ | |||
4834 4835 4836 4837 4838 4839 4840 | TclGetInt4AtPtr(pc+5))); /* * Get the length of the list, making sure that it really is a list * in the process. */ | | | 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 |
TclGetInt4AtPtr(pc+5)));
/*
* Get the length of the list, making sure that it really is a list
* in the process.
*/
if (TclListObjLengthM(interp, valuePtr, &objc) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
/*
* Skip a lot of work if we're about to throw the result away (common
* with uses of [lassign]).
|
| ︙ | ︙ | |||
4899 4900 4901 4902 4903 4904 4905 |
case INST_LIST_IN:
case INST_LIST_NOT_IN: /* Basic list containment operators. */
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
| | | | 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 |
case INST_LIST_IN:
case INST_LIST_NOT_IN: /* Basic list containment operators. */
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
if (TclListObjLengthM(interp, value2Ptr, &length) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
match = 0;
if (length > 0) {
size_t i = 0;
Tcl_Obj *o;
/*
* An empty list doesn't match anything.
*/
do {
|
| ︙ | ︙ | |||
5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 |
* but creating the object as a string seems to be faster in
* practical use.
*/
if (ch == -1) {
TclNewObj(objResultPtr);
} else {
slength = Tcl_UniCharToUtf(ch, buf);
if ((ch >= 0xD800) && (slength < 3)) {
slength += Tcl_UniCharToUtf(-1, buf + slength);
}
objResultPtr = Tcl_NewStringObj(buf, slength);
}
}
TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
| > > | 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 |
* but creating the object as a string seems to be faster in
* practical use.
*/
if (ch == -1) {
TclNewObj(objResultPtr);
} else {
slength = Tcl_UniCharToUtf(ch, buf);
#if TCL_UTF_MAX < 4
if ((ch >= 0xD800) && (slength < 3)) {
slength += Tcl_UniCharToUtf(-1, buf + slength);
}
#endif
objResultPtr = Tcl_NewStringObj(buf, slength);
}
}
TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
|
| ︙ | ︙ | |||
5503 5504 5505 5506 5507 5508 5509 |
void *ptr1, *ptr2;
int type1, type2;
Tcl_WideInt w1, w2, wResult;
case INST_NUM_TYPE:
if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) {
type1 = 0;
| < < < < < < < < | 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 |
void *ptr1, *ptr2;
int type1, type2;
Tcl_WideInt w1, w2, wResult;
case INST_NUM_TYPE:
if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) {
type1 = 0;
}
TclNewIntObj(objResultPtr, type1);
TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1));
NEXT_INST_F(1, 1, 1);
case INST_EQ:
case INST_NEQ:
|
| ︙ | ︙ | |||
5771 5772 5773 5774 5775 5776 5777 |
} else {
int shift = (int) w2;
/*
* Handle shifts within the native long range.
*/
| | | 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 |
} else {
int shift = (int) w2;
/*
* Handle shifts within the native long range.
*/
if (((size_t)shift < CHAR_BIT*sizeof(long))
&& !((w1>0 ? w1 : ~w1) &
-(1UL<<(CHAR_BIT*sizeof(long) - 1 - shift)))) {
wResult = (Tcl_WideUInt)w1 << shift;
goto wideResultOfArithmetic;
}
}
|
| ︙ | ︙ | |||
6215 6216 6217 6218 6219 6220 6221 |
TRACE(("=> CONTINUE!\n"));
goto processExceptionReturn;
{
ForeachInfo *infoPtr;
Tcl_Obj *listPtr, **elements;
ForeachVarList *varListPtr;
| | < | < | 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 |
TRACE(("=> CONTINUE!\n"));
goto processExceptionReturn;
{
ForeachInfo *infoPtr;
Tcl_Obj *listPtr, **elements;
ForeachVarList *varListPtr;
size_t numLists, listLen, numVars, listTmpDepth;
size_t iterNum, iterMax, iterTmp;
size_t varIndex, valIndex, i, j;
case INST_FOREACH_START:
/*
* Initialize the data for the looping construct, pushing the
* corresponding Tcl_Objs to the stack.
*/
|
| ︙ | ︙ | |||
6242 6243 6244 6245 6246 6247 6248 |
iterMax = 0;
listTmpDepth = numLists-1;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listPtr = OBJ_AT_DEPTH(listTmpDepth);
| | | | 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 |
iterMax = 0;
listTmpDepth = numLists-1;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listPtr = OBJ_AT_DEPTH(listTmpDepth);
if (TclListObjLengthM(interp, listPtr, &listLen) != TCL_OK) {
TRACE_APPEND(("ERROR converting list %" TCL_Z_MODIFIER "d, \"%s\": %s",
i, O2S(listPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
if (Tcl_IsShared(listPtr)) {
objPtr = TclListObjCopy(NULL, listPtr);
Tcl_IncrRefCount(objPtr);
Tcl_DecrRefCount(listPtr);
|
| ︙ | ︙ | |||
6323 6324 6325 6326 6327 6328 6329 |
listTmpDepth = numLists + 1;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listPtr = OBJ_AT_DEPTH(listTmpDepth);
| | | 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 |
listTmpDepth = numLists + 1;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listPtr = OBJ_AT_DEPTH(listTmpDepth);
TclListObjGetElementsM(interp, listPtr, &listLen, &elements);
valIndex = (iterNum * numVars);
for (j = 0; j < numVars; j++) {
if (valIndex >= listLen) {
TclNewObj(valuePtr);
} else {
valuePtr = elements[valIndex];
|
| ︙ | ︙ | |||
6352 6353 6354 6355 6356 6357 6358 |
Tcl_IncrRefCount(valuePtr);
}
} else {
DECACHE_STACK_INFO();
if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL,
valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){
CACHE_STACK_INFO();
| | | 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 |
Tcl_IncrRefCount(valuePtr);
}
} else {
DECACHE_STACK_INFO();
if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL,
valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){
CACHE_STACK_INFO();
TRACE_APPEND(("ERROR init. index temp %" TCL_Z_MODIFIER "u: %.30s",
varIndex, O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
CACHE_STACK_INFO();
}
valIndex++;
}
|
| ︙ | ︙ | |||
6399 6400 6401 6402 6403 6404 6405 | * - collecting obj (unshared) * The instruction lappends the result to the collecting obj. */ tmpPtr = OBJ_AT_DEPTH(1); infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1; numLists = infoPtr->numLists; | | | | | | | | 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 |
* - collecting obj (unshared)
* The instruction lappends the result to the collecting obj.
*/
tmpPtr = OBJ_AT_DEPTH(1);
infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1;
numLists = infoPtr->numLists;
TRACE_APPEND(("=> appending to list at depth %" TCL_Z_MODIFIER "u\n", 3 + numLists));
objPtr = OBJ_AT_DEPTH(3 + numLists);
Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS);
NEXT_INST_F(1, 1, 0);
}
break;
case INST_BEGIN_CATCH4:
/*
* Record start of the catch command with exception range index equal
* to the operand. Push the current stack depth onto the special catch
* stack.
*/
*(++catchTop) = (Tcl_Obj *)UINT2PTR(CURR_DEPTH);
TRACE(("%u => catchTop=%" TCL_Z_MODIFIER "u, stackTop=%" TCL_Z_MODIFIER "u\n",
TclGetUInt4AtPtr(pc+1), (size_t)(catchTop - initCatchTop - 1),
CURR_DEPTH));
NEXT_INST_F(5, 0, 0);
break;
case INST_END_CATCH:
catchTop--;
DECACHE_STACK_INFO();
Tcl_ResetResult(interp);
CACHE_STACK_INFO();
result = TCL_OK;
TRACE(("=> catchTop=%" TCL_Z_MODIFIER "u\n", (size_t)(catchTop - initCatchTop - 1)));
NEXT_INST_F(1, 0, 0);
break;
case INST_PUSH_RESULT:
objResultPtr = Tcl_GetObjResult(interp);
TRACE_WITH_OBJ(("=> "), objResultPtr);
|
| ︙ | ︙ | |||
6481 6482 6483 6484 6485 6486 6487 |
/*
* -----------------------------------------------------------------
* Start of dictionary-related instructions.
*/
{
| | > | > | > | 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 6499 6500 6501 6502 6503 6504 6505 6506 6507 6508 6509 6510 6511 6512 6513 6514 |
/*
* -----------------------------------------------------------------
* Start of dictionary-related instructions.
*/
{
int opnd2, allocateDict, done, allocdict;
size_t i;
Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr;
Tcl_Obj *emptyPtr, **keyPtrPtr;
Tcl_DictSearch *searchPtr;
DictUpdateInfo *duiPtr;
case INST_DICT_VERIFY: {
size_t size;
dictPtr = OBJ_AT_TOS;
TRACE(("\"%.30s\" => ", O2S(dictPtr)));
if (Tcl_DictObjSize(interp, dictPtr, &size) != TCL_OK) {
TRACE_APPEND(("ERROR verifying dictionary nature of \"%.30s\": %s\n",
O2S(dictPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
TRACE_APPEND(("OK\n"));
NEXT_INST_F(1, 1, 0);
}
break;
case INST_DICT_EXISTS: {
int found;
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
|
| ︙ | ︙ | |||
6935 6936 6937 6938 6939 6940 6941 |
CACHE_STACK_INFO();
if (dictPtr == NULL) {
TRACE_ERROR(interp);
goto gotError;
}
}
Tcl_IncrRefCount(dictPtr);
| | | | 6939 6940 6941 6942 6943 6944 6945 6946 6947 6948 6949 6950 6951 6952 6953 6954 6955 6956 6957 6958 |
CACHE_STACK_INFO();
if (dictPtr == NULL) {
TRACE_ERROR(interp);
goto gotError;
}
}
Tcl_IncrRefCount(dictPtr);
if (TclListObjGetElementsM(interp, OBJ_AT_TOS, &length,
&keyPtrPtr) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
if (length != duiPtr->length) {
Tcl_Panic("dictUpdateStart argument length mismatch");
}
for (i=0 ; i<length ; i++) {
if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i],
&valuePtr) != TCL_OK) {
TRACE_ERROR(interp);
Tcl_DecrRefCount(dictPtr);
|
| ︙ | ︙ | |||
6995 6996 6997 6998 6999 7000 7001 |
CACHE_STACK_INFO();
}
if (dictPtr == NULL) {
TRACE_APPEND(("storage was unset\n"));
NEXT_INST_F(9, 1, 0);
}
if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK
| | | 6999 7000 7001 7002 7003 7004 7005 7006 7007 7008 7009 7010 7011 7012 7013 |
CACHE_STACK_INFO();
}
if (dictPtr == NULL) {
TRACE_APPEND(("storage was unset\n"));
NEXT_INST_F(9, 1, 0);
}
if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK
|| TclListObjGetElementsM(interp, OBJ_AT_TOS, &length,
&keyPtrPtr) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
allocdict = Tcl_IsShared(dictPtr);
if (allocdict) {
dictPtr = Tcl_DuplicateObj(dictPtr);
|
| ︙ | ︙ | |||
7054 7055 7056 7057 7058 7059 7060 |
TRACE_APPEND(("written back\n"));
NEXT_INST_F(9, 1, 0);
case INST_DICT_EXPAND:
dictPtr = OBJ_UNDER_TOS;
listPtr = OBJ_AT_TOS;
TRACE(("\"%.30s\" \"%.30s\" =>", O2S(dictPtr), O2S(listPtr)));
| | | | 7058 7059 7060 7061 7062 7063 7064 7065 7066 7067 7068 7069 7070 7071 7072 7073 7074 7075 7076 7077 7078 7079 7080 7081 7082 7083 7084 7085 7086 7087 7088 7089 7090 |
TRACE_APPEND(("written back\n"));
NEXT_INST_F(9, 1, 0);
case INST_DICT_EXPAND:
dictPtr = OBJ_UNDER_TOS;
listPtr = OBJ_AT_TOS;
TRACE(("\"%.30s\" \"%.30s\" =>", O2S(dictPtr), O2S(listPtr)));
if (TclListObjGetElementsM(interp, listPtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
objResultPtr = TclDictWithInit(interp, dictPtr, objc, objv);
if (objResultPtr == NULL) {
TRACE_ERROR(interp);
goto gotError;
}
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
case INST_DICT_RECOMBINE_STK:
keysPtr = POP_OBJECT();
varNamePtr = OBJ_UNDER_TOS;
listPtr = OBJ_AT_TOS;
TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ",
O2S(varNamePtr), O2S(valuePtr), O2S(keysPtr)));
if (TclListObjGetElementsM(interp, listPtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
TclDecrRefCount(keysPtr);
goto gotError;
}
varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL,
TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr);
if (varPtr == NULL) {
|
| ︙ | ︙ | |||
7103 7104 7105 7106 7107 7108 7109 |
case INST_DICT_RECOMBINE_IMM:
opnd = TclGetUInt4AtPtr(pc+1);
listPtr = OBJ_UNDER_TOS;
keysPtr = OBJ_AT_TOS;
varPtr = LOCAL(opnd);
TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr),
O2S(keysPtr)));
| | | 7107 7108 7109 7110 7111 7112 7113 7114 7115 7116 7117 7118 7119 7120 7121 |
case INST_DICT_RECOMBINE_IMM:
opnd = TclGetUInt4AtPtr(pc+1);
listPtr = OBJ_UNDER_TOS;
keysPtr = OBJ_AT_TOS;
varPtr = LOCAL(opnd);
TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr),
O2S(keysPtr)));
if (TclListObjGetElementsM(interp, listPtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
DECACHE_STACK_INFO();
|
| ︙ | ︙ | |||
7224 7225 7226 7227 7228 7229 7230 |
while (cleanup--) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
if (result == TCL_BREAK) {
result = TCL_OK;
pc = (codePtr->codeStart + rangePtr->breakOffset);
| | | | | 7228 7229 7230 7231 7232 7233 7234 7235 7236 7237 7238 7239 7240 7241 7242 7243 7244 7245 7246 7247 7248 7249 7250 7251 7252 7253 7254 |
while (cleanup--) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
if (result == TCL_BREAK) {
result = TCL_OK;
pc = (codePtr->codeStart + rangePtr->breakOffset);
TRACE_APPEND(("%s, range at %" TCL_Z_MODIFIER "u, new pc %" TCL_Z_MODIFIER "u\n",
StringForResultCode(result),
rangePtr->codeOffset, rangePtr->breakOffset));
NEXT_INST_F(0, 0, 0);
}
if (rangePtr->continueOffset == TCL_INDEX_NONE) {
TRACE_APPEND(("%s, loop w/o continue, checking for catch\n",
StringForResultCode(result)));
goto checkForCatch;
}
result = TCL_OK;
pc = (codePtr->codeStart + rangePtr->continueOffset);
TRACE_APPEND(("%s, range at %" TCL_Z_MODIFIER "u, new pc %" TCL_Z_MODIFIER "u\n",
StringForResultCode(result),
rangePtr->codeOffset, rangePtr->continueOffset));
NEXT_INST_F(0, 0, 0);
}
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
objPtr = Tcl_GetObjResult(interp);
|
| ︙ | ︙ | |||
7326 7327 7328 7329 7330 7331 7332 |
/*
* Clear all expansions that may have started after the last
* INST_BEGIN_CATCH.
*/
while (auxObjList) {
if ((catchTop != initCatchTop)
| | | | 7330 7331 7332 7333 7334 7335 7336 7337 7338 7339 7340 7341 7342 7343 7344 7345 |
/*
* Clear all expansions that may have started after the last
* INST_BEGIN_CATCH.
*/
while (auxObjList) {
if ((catchTop != initCatchTop)
&& (PTR2UINT(*catchTop) >
PTR2UINT(auxObjList->internalRep.twoPtrValue.ptr2))) {
break;
}
POP_TAUX_OBJ();
}
/*
* We must not catch if the script in progress has been canceled with
|
| ︙ | ︙ | |||
7402 7403 7404 7405 7406 7407 7408 |
* "exception". It was found either by checkForCatch just above or by
* an instruction during break, continue, or error processing. Jump to
* its catchOffset after unwinding the operand stack to the depth it
* had when starting to execute the range's catch command.
*/
processCatch:
| | | | | | | 7406 7407 7408 7409 7410 7411 7412 7413 7414 7415 7416 7417 7418 7419 7420 7421 7422 7423 7424 7425 7426 7427 7428 7429 |
* "exception". It was found either by checkForCatch just above or by
* an instruction during break, continue, or error processing. Jump to
* its catchOffset after unwinding the operand stack to the depth it
* had when starting to execute the range's catch command.
*/
processCatch:
while (CURR_DEPTH > PTR2UINT(*catchTop)) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
fprintf(stdout, " ... found catch at %" TCL_Z_MODIFIER "u, catchTop=%" TCL_Z_MODIFIER "u, "
"unwound to %" TCL_Z_MODIFIER "u, new pc %" TCL_Z_MODIFIER "u\n",
rangePtr->codeOffset, (size_t)(catchTop - initCatchTop - 1),
PTR2UINT(*catchTop), (size_t)rangePtr->catchOffset);
}
#endif
pc = (codePtr->codeStart + rangePtr->catchOffset);
NEXT_INST_F(0, 0, 0); /* Restart the execution loop at pc. */
/*
* end of infinite loop dispatching on instructions.
|
| ︙ | ︙ | |||
7448 7449 7450 7451 7452 7453 7454 |
objPtr = POP_OBJECT();
Tcl_DecrRefCount(objPtr);
}
if (tosPtr < initTosPtr) {
fprintf(stderr,
"\nTclNRExecuteByteCode: abnormal return at pc %" TCL_Z_MODIFIER "u: "
| | | | 7452 7453 7454 7455 7456 7457 7458 7459 7460 7461 7462 7463 7464 7465 7466 7467 7468 |
objPtr = POP_OBJECT();
Tcl_DecrRefCount(objPtr);
}
if (tosPtr < initTosPtr) {
fprintf(stderr,
"\nTclNRExecuteByteCode: abnormal return at pc %" TCL_Z_MODIFIER "u: "
"stack top %" TCL_Z_MODIFIER "u < entry stack top %d\n",
(size_t)(pc - codePtr->codeStart),
CURR_DEPTH, 0);
Tcl_Panic("TclNRExecuteByteCode execution failure: end stack top < start stack top");
}
CLANG_ASSERT(bcFramePtr);
}
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
TclReleaseByteCode(codePtr);
|
| ︙ | ︙ | |||
8676 8677 8678 8679 8680 8681 8682 |
fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_Z_MODIFIER "u, epoch %" TCL_Z_MODIFIER "u, interp 0x%p (epoch %" TCL_Z_MODIFIER "u)\n",
codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr,
iPtr->compileEpoch);
fprintf(stdout, " Source: ");
TclPrintSource(stdout, codePtr->source, 60);
| | | > | | | | | | | 8680 8681 8682 8683 8684 8685 8686 8687 8688 8689 8690 8691 8692 8693 8694 8695 8696 8697 8698 8699 8700 8701 8702 8703 8704 8705 8706 8707 8708 8709 8710 8711 8712 8713 8714 8715 8716 8717 |
fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_Z_MODIFIER "u, epoch %" TCL_Z_MODIFIER "u, interp 0x%p (epoch %" TCL_Z_MODIFIER "u)\n",
codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr,
iPtr->compileEpoch);
fprintf(stdout, " Source: ");
TclPrintSource(stdout, codePtr->source, 60);
fprintf(stdout, "\n Cmds %" TCL_Z_MODIFIER "u, src %" TCL_Z_MODIFIER "u, inst %" TCL_Z_MODIFIER "u, litObjs %" TCL_Z_MODIFIER "u, aux %" TCL_Z_MODIFIER "u, stkDepth %" TCL_Z_MODIFIER "u, code/src %.2f\n",
codePtr->numCommands, codePtr->numSrcBytes,
codePtr->numCodeBytes, codePtr->numLitObjects,
codePtr->numAuxDataItems, codePtr->maxStackDepth,
#ifdef TCL_COMPILE_STATS
codePtr->numSrcBytes?
((float)codePtr->structureSize)/codePtr->numSrcBytes :
#endif
0.0);
#ifdef TCL_COMPILE_STATS
fprintf(stdout, " Code %" TCL_Z_MODIFIER "u = header %" TCL_Z_MODIFIER "u+inst %" TCL_Z_MODIFIER
"u+litObj %" TCL_Z_MODIFIER "u+exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER "u+cmdMap %" TCL_Z_MODIFIER "u\n",
codePtr->structureSize,
offsetof(ByteCode, localCachePtr),
codePtr->numCodeBytes,
codePtr->numLitObjects * sizeof(Tcl_Obj *),
codePtr->numExceptRanges*sizeof(ExceptionRange),
codePtr->numAuxDataItems * sizeof(AuxData),
codePtr->numCmdLocBytes);
#endif /* TCL_COMPILE_STATS */
if (procPtr != NULL) {
fprintf(stdout,
" Proc 0x%p, refCt %" TCL_Z_MODIFIER "u, args %" TCL_Z_MODIFIER "u, compiled locals %" TCL_Z_MODIFIER "u\n",
procPtr, procPtr->refCount, procPtr->numArgs,
procPtr->numCompiledLocals);
}
}
#endif /* TCL_COMPILE_DEBUG */
/*
|
| ︙ | ︙ | |||
8731 8732 8733 8734 8735 8736 8737 |
#ifdef TCL_COMPILE_DEBUG
static void
ValidatePcAndStackTop(
ByteCode *codePtr, /* The bytecode whose summary is printed to
* stdout. */
const unsigned char *pc, /* Points to first byte of a bytecode
* instruction. The program counter. */
| | | | | | | | | | | | 8736 8737 8738 8739 8740 8741 8742 8743 8744 8745 8746 8747 8748 8749 8750 8751 8752 8753 8754 8755 8756 8757 8758 8759 8760 8761 8762 8763 8764 8765 8766 8767 8768 8769 8770 8771 8772 8773 8774 8775 8776 8777 8778 8779 |
#ifdef TCL_COMPILE_DEBUG
static void
ValidatePcAndStackTop(
ByteCode *codePtr, /* The bytecode whose summary is printed to
* stdout. */
const unsigned char *pc, /* Points to first byte of a bytecode
* instruction. The program counter. */
size_t stackTop, /* Current stack top. Must be between
* stackLowerBound and stackUpperBound
* (inclusive). */
int checkStack) /* 0 if the stack depth check should be
* skipped. */
{
size_t stackUpperBound = codePtr->maxStackDepth;
/* Greatest legal value for stackTop. */
size_t relativePc = (size_t)(pc - codePtr->codeStart);
size_t codeStart = (size_t)codePtr->codeStart;
size_t codeEnd = (size_t)
(codePtr->codeStart + codePtr->numCodeBytes);
unsigned char opCode = *pc;
if ((PTR2UINT(pc) < codeStart) || (PTR2UINT(pc) > codeEnd)) {
fprintf(stderr, "\nBad instruction pc 0x%p in TclNRExecuteByteCode\n",
pc);
Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc");
}
if (opCode >= LAST_INST_OPCODE) {
fprintf(stderr, "\nBad opcode %u at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode\n",
opCode, relativePc);
Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode");
}
if (checkStack &&
(stackTop > stackUpperBound)) {
size_t numChars;
const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL);
fprintf(stderr, "\nBad stack top %" TCL_Z_MODIFIER "u at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode (min 0, max %" TCL_Z_MODIFIER "u)",
stackTop, relativePc, stackUpperBound);
if (cmd != NULL) {
Tcl_Obj *message;
TclNewLiteralStringObj(message, "\n executing ");
Tcl_IncrRefCount(message);
Tcl_AppendLimitedToObj(message, cmd, numChars, 100, NULL);
|
| ︙ | ︙ | |||
8919 8920 8921 8922 8923 8924 8925 |
if (!hePtr) {
return;
}
srcOffset = cfPtr->cmd - codePtr->source;
eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr);
| | | 8924 8925 8926 8927 8928 8929 8930 8931 8932 8933 8934 8935 8936 8937 8938 |
if (!hePtr) {
return;
}
srcOffset = cfPtr->cmd - codePtr->source;
eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr);
for (i=0; i < (int)eclPtr->nuloc; i++) {
if (eclPtr->loc[i].srcOffset == srcOffset) {
locPtr = eclPtr->loc+i;
break;
}
}
if (locPtr == NULL) {
Tcl_Panic("LocSearch failure");
|
| ︙ | ︙ | |||
8974 8975 8976 8977 8978 8979 8980 |
size_t codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */
int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */
int bestSrcLength = -1; /* Initialized to avoid compiler warning. */
int bestCmdIdx = -1;
/* The pc must point within the bytecode */
| | | 8979 8980 8981 8982 8983 8984 8985 8986 8987 8988 8989 8990 8991 8992 8993 |
size_t codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */
int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */
int bestSrcLength = -1; /* Initialized to avoid compiler warning. */
int bestCmdIdx = -1;
/* The pc must point within the bytecode */
assert (pcOffset < codePtr->numCodeBytes);
/*
* Decode the code and source offset and length for each command. The
* closest enclosing command is the last one whose code started before
* pcOffset.
*/
|
| ︙ | ︙ | |||
9115 9116 9117 9118 9119 9120 9121 |
* closer loop ranges). If TCL_CONTINUE, look
* for loop ranges that define a continue
* point or a catch range. */
ByteCode *codePtr) /* Points to the ByteCode in which to search
* for the enclosing ExceptionRange. */
{
ExceptionRange *rangeArrayPtr;
| | | 9120 9121 9122 9123 9124 9125 9126 9127 9128 9129 9130 9131 9132 9133 9134 |
* closer loop ranges). If TCL_CONTINUE, look
* for loop ranges that define a continue
* point or a catch range. */
ByteCode *codePtr) /* Points to the ByteCode in which to search
* for the enclosing ExceptionRange. */
{
ExceptionRange *rangeArrayPtr;
size_t numRanges = codePtr->numExceptRanges;
ExceptionRange *rangePtr;
size_t pcOffset = pc - codePtr->codeStart;
size_t start;
if (numRanges == 0) {
return NULL;
}
|
| ︙ | ︙ | |||
9142 9143 9144 9145 9146 9147 9148 |
(pcOffset < (start + rangePtr->numCodeBytes))) {
if (rangePtr->type == CATCH_EXCEPTION_RANGE) {
return rangePtr;
}
if (searchMode == TCL_BREAK) {
return rangePtr;
}
| | | 9147 9148 9149 9150 9151 9152 9153 9154 9155 9156 9157 9158 9159 9160 9161 |
(pcOffset < (start + rangePtr->numCodeBytes))) {
if (rangePtr->type == CATCH_EXCEPTION_RANGE) {
return rangePtr;
}
if (searchMode == TCL_BREAK) {
return rangePtr;
}
if (searchMode == TCL_CONTINUE && rangePtr->continueOffset != TCL_INDEX_NONE){
return rangePtr;
}
}
}
return NULL;
}
|
| ︙ | ︙ | |||
9324 9325 9326 9327 9328 9329 9330 |
+ (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj))
+ statsPtr->totalLitStringBytes;
totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes;
numCurrentByteCodes =
statsPtr->numCompilations - statsPtr->numByteCodesFreed;
currentHeaderBytes = numCurrentByteCodes
| | | 9329 9330 9331 9332 9333 9334 9335 9336 9337 9338 9339 9340 9341 9342 9343 |
+ (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj))
+ statsPtr->totalLitStringBytes;
totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes;
numCurrentByteCodes =
statsPtr->numCompilations - statsPtr->numByteCodesFreed;
currentHeaderBytes = numCurrentByteCodes
* offsetof(ByteCode, localCachePtr);
literalMgmtBytes = sizeof(LiteralTable)
+ (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *))
+ (iPtr->literalTable.numEntries * sizeof(LiteralEntry));
currentLiteralBytes = literalMgmtBytes
+ iPtr->literalTable.numEntries * sizeof(Tcl_Obj)
+ statsPtr->currentLitStringBytes;
currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes;
|
| ︙ | ︙ | |||
9576 9577 9578 9579 9580 9581 9582 |
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
if (statsPtr->srcCount[i] > 0) {
minSizeDecade = i;
break;
}
}
| | | 9581 9582 9583 9584 9585 9586 9587 9588 9589 9590 9591 9592 9593 9594 9595 |
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
if (statsPtr->srcCount[i] > 0) {
minSizeDecade = i;
break;
}
}
for (i = 31; i != TCL_INDEX_NONE; i--) {
if (statsPtr->srcCount[i] > 0) {
break; /* maxSizeDecade to consume 'i' value
* below... */
}
}
maxSizeDecade = i;
sum = 0;
|
| ︙ | ︙ | |||
9600 9601 9602 9603 9604 9605 9606 |
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
if (statsPtr->byteCodeCount[i] > 0) {
minSizeDecade = i;
break;
}
}
| | | 9605 9606 9607 9608 9609 9610 9611 9612 9613 9614 9615 9616 9617 9618 9619 |
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
if (statsPtr->byteCodeCount[i] > 0) {
minSizeDecade = i;
break;
}
}
for (i = 31; i != TCL_INDEX_NONE; i--) {
if (statsPtr->byteCodeCount[i] > 0) {
break; /* maxSizeDecade to consume 'i' value
* below... */
}
}
maxSizeDecade = i;
sum = 0;
|
| ︙ | ︙ | |||
9624 9625 9626 9627 9628 9629 9630 |
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
if (statsPtr->lifetimeCount[i] > 0) {
minSizeDecade = i;
break;
}
}
| | | 9629 9630 9631 9632 9633 9634 9635 9636 9637 9638 9639 9640 9641 9642 9643 |
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
if (statsPtr->lifetimeCount[i] > 0) {
minSizeDecade = i;
break;
}
}
for (i = 31; i != TCL_INDEX_NONE; i--) {
if (statsPtr->lifetimeCount[i] > 0) {
break; /* maxSizeDecade to consume 'i' value
* below... */
}
}
maxSizeDecade = i;
sum = 0;
|
| ︙ | ︙ |
Changes to generic/tclFCmd.c.
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | * See the user documentation. * *--------------------------------------------------------------------------- */ int TclFileRenameCmd( | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
* See the user documentation.
*
*---------------------------------------------------------------------------
*/
int
TclFileRenameCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interp for error reporting or recursive
* calls in the case of a tricky rename. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
{
return FileCopyRename(interp, objc, objv, 0);
}
|
| ︙ | ︙ | |||
72 73 74 75 76 77 78 | * See the user documentation. * *--------------------------------------------------------------------------- */ int TclFileCopyCmd( | | | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 |
* See the user documentation.
*
*---------------------------------------------------------------------------
*/
int
TclFileCopyCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Used for error reporting or recursive calls
* in the case of a tricky copy. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
{
return FileCopyRename(interp, objc, objv, 1);
}
|
| ︙ | ︙ | |||
210 211 212 213 214 215 216 | * See the user documentation. * *---------------------------------------------------------------------- */ int TclFileMakeDirsCmd( | | | > | 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
TclFileMakeDirsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Used for error reporting. */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
{
Tcl_Obj *errfile = NULL;
int result, i;
size_t j, pobjc;
Tcl_Obj *split = NULL;
Tcl_Obj *target = NULL;
Tcl_StatBuf statBuf;
result = TCL_OK;
for (i = 1; i < objc; i++) {
if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
|
| ︙ | ︙ | |||
334 335 336 337 338 339 340 | * See the user documentation. * *---------------------------------------------------------------------- */ int TclFileDeleteCmd( | | | 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
TclFileDeleteCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Used for error reporting */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
{
int i, force, result;
Tcl_Obj *errfile;
Tcl_Obj *errorBuffer = NULL;
|
| ︙ | ︙ | |||
866 867 868 869 870 871 872 | * None. * *--------------------------------------------------------------------------- */ static Tcl_Obj * FileBasename( | | | < < < < < < < < < | | | 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 |
* None.
*
*---------------------------------------------------------------------------
*/
static Tcl_Obj *
FileBasename(
TCL_UNUSED(Tcl_Interp *), /* Interp, for error return. */
Tcl_Obj *pathPtr) /* Path whose basename to extract. */
{
size_t objc;
Tcl_Obj *splitPtr;
Tcl_Obj *resultPtr = NULL;
splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
Tcl_IncrRefCount(splitPtr);
if (objc != 0) {
/*
* Return the last component, unless it is the only component, and it
* is the root of an absolute path.
*/
if (objc > 0) {
Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr);
if ((objc == 1) &&
(Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) {
|
| ︙ | ︙ | |||
942 943 944 945 946 947 948 | * May set file attributes for the file name. * *---------------------------------------------------------------------- */ int TclFileAttrsCmd( | | | | 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 |
* May set file attributes for the file name.
*
*----------------------------------------------------------------------
*/
int
TclFileAttrsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter for error reporting. */
int objc, /* Number of command line arguments. */
Tcl_Obj *const objv[]) /* The command line objects. */
{
int result;
const char *const *attributeStrings;
const char **attributeStringsAllocated = NULL;
Tcl_Obj *objStrings = NULL;
size_t numObjStrings = TCL_INDEX_NONE;
Tcl_Obj *filePtr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name ?-option value ...?");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
975 976 977 978 979 980 981 |
/*
* Get the set of attribute names from the filesystem.
*/
attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings);
if (attributeStrings == NULL) {
| | | 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 |
/*
* Get the set of attribute names from the filesystem.
*/
attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings);
if (attributeStrings == NULL) {
size_t index;
Tcl_Obj *objPtr;
if (objStrings == NULL) {
if (Tcl_GetErrno() != 0) {
/*
* There was an error, probably that the filePtr is not
* accepted by any filesystem
|
| ︙ | ︙ | |||
1002 1003 1004 1005 1006 1007 1008 | Tcl_IncrRefCount(objStrings); /* * Use objStrings as a list object. */ | | | 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 |
Tcl_IncrRefCount(objStrings);
/*
* Use objStrings as a list object.
*/
if (TclListObjLengthM(interp, objStrings, &numObjStrings) != TCL_OK) {
goto end;
}
attributeStringsAllocated = (const char **)
TclStackAlloc(interp, (1+numObjStrings) * sizeof(char *));
for (index = 0; index < numObjStrings; index++) {
Tcl_ListObjIndex(interp, objStrings, index, &objPtr);
attributeStringsAllocated[index] = TclGetString(objPtr);
|
| ︙ | ︙ | |||
1158 1159 1160 1161 1162 1163 1164 | * May create a new link. * *---------------------------------------------------------------------- */ int TclFileLinkCmd( | | | 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 |
* May create a new link.
*
*----------------------------------------------------------------------
*/
int
TclFileLinkCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *contents;
int index;
|
| ︙ | ︙ | |||
1309 1310 1311 1312 1313 1314 1315 | * None. * *---------------------------------------------------------------------- */ int TclFileReadLinkCmd( | | | 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 |
* None.
*
*----------------------------------------------------------------------
*/
int
TclFileReadLinkCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *contents;
if (objc != 2) {
|
| ︙ | ︙ | |||
1360 1361 1362 1363 1364 1365 1366 | * to a variable, so reentrancy is a potential issue. * *--------------------------------------------------------------------------- */ int TclFileTemporaryCmd( | | | 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 |
* to a variable, so reentrancy is a potential issue.
*
*---------------------------------------------------------------------------
*/
int
TclFileTemporaryCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *nameVarObj = NULL; /* Variable to store the name of the temporary
* file in. */
Tcl_Obj *nameObj = NULL; /* Object that will contain the filename. */
|
| ︙ | ︙ | |||
1519 1520 1521 1522 1523 1524 1525 | * Creates a temporary directory. * *--------------------------------------------------------------------------- */ int TclFileTempDirCmd( | | | 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 |
* Creates a temporary directory.
*
*---------------------------------------------------------------------------
*/
int
TclFileTempDirCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *dirNameObj; /* Object that will contain the directory
* name. */
Tcl_Obj *baseDirObj = NULL, *nameBaseObj = NULL;
|
| ︙ | ︙ | |||
1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 |
"can't create temporary directory: %s",
Tcl_PosixError(interp)));
return TCL_ERROR;
}
Tcl_SetObjResult(interp, dirNameObj);
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 |
"can't create temporary directory: %s",
Tcl_PosixError(interp)));
return TCL_ERROR;
}
Tcl_SetObjResult(interp, dirNameObj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclFileHomeCmd --
*
* This function is invoked to process the "file home" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclFileHomeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *homeDirObj;
if (objc != 1 && objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?user?");
return TCL_ERROR;
}
homeDirObj = TclGetHomeDirObj(interp, objc == 1 ? NULL : Tcl_GetString(objv[1]));
if (homeDirObj == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, homeDirObj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclFileTildeExpandCmd --
*
* This function is invoked to process the "file tildeexpand" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclFileTildeExpandCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *expandedPathObj;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "path");
return TCL_ERROR;
}
expandedPathObj = TclResolveTildePath(interp, objv[1]);
if (expandedPathObj == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, expandedPathObj);
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclFileName.c.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 | TclPlatformType tclPlatform = TCL_PLATFORM_UNIX; /* * Prototypes for local procedures defined in this file: */ | < < | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | TclPlatformType tclPlatform = TCL_PLATFORM_UNIX; /* * Prototypes for local procedures defined in this file: */ static const char * ExtractWinRoot(const char *path, Tcl_DString *resultPtr, int offset, Tcl_PathType *typePtr); static int SkipToChar(char **stringPtr, int match); static Tcl_Obj * SplitWinPath(const char *path); static Tcl_Obj * SplitUnixPath(const char *path); static int DoGlob(Tcl_Interp *interp, Tcl_Obj *resultPtr, |
| ︙ | ︙ | |||
358 359 360 361 362 363 364 | * Determines whether a given path is relative to the current directory, * relative to the current volume, or absolute, but ONLY FOR THE NATIVE * FILESYSTEM. This function is called from tclIOUtil.c (but needs to be * here due to its dependence on static variables/functions in this * file). The exported function Tcl_FSGetPathType should be used by * extensions. * | < < < < < < | < < < < < < < < < < < < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 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 |
* Determines whether a given path is relative to the current directory,
* relative to the current volume, or absolute, but ONLY FOR THE NATIVE
* FILESYSTEM. This function is called from tclIOUtil.c (but needs to be
* here due to its dependence on static variables/functions in this
* file). The exported function Tcl_FSGetPathType should be used by
* extensions.
*
* Results:
* Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
* TCL_PATH_VOLUME_RELATIVE.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_PathType
TclpGetNativePathType(
Tcl_Obj *pathPtr, /* Native path of interest */
size_t *driveNameLengthPtr, /* Returns length of drive, if non-NULL and
* path was absolute */
Tcl_Obj **driveNameRef)
{
Tcl_PathType type = TCL_PATH_ABSOLUTE;
const char *path = TclGetString(pathPtr);
switch (tclPlatform) {
case TCL_PLATFORM_UNIX: {
const char *origPath = path;
/*
* Paths that begin with / are absolute.
*/
if (path[0] == '/') {
++path;
#if defined(__CYGWIN__) || defined(__QNX__)
/*
* Check for "//" network path prefix
*/
if ((*path == '/') && path[1] && (path[1] != '/')) {
path += 2;
while (*path && *path != '/') {
++path;
}
#if defined(__CYGWIN__)
/* UNC paths need to be followed by a share name */
if (*path++ && (*path && *path != '/')) {
++path;
while (*path && *path != '/') {
++path;
}
} else {
path = origPath + 1;
}
#endif
}
#endif
if (driveNameLengthPtr != NULL) {
/*
* We need this addition in case the QNX or Cygwin code was used.
*/
*driveNameLengthPtr = (path - origPath);
}
} else {
type = TCL_PATH_RELATIVE;
}
break;
}
case TCL_PLATFORM_WINDOWS: {
Tcl_DString ds;
const char *rootEnd;
Tcl_DStringInit(&ds);
rootEnd = ExtractWinRoot(path, &ds, 0, &type);
if ((rootEnd != path) && (driveNameLengthPtr != NULL)) {
*driveNameLengthPtr = rootEnd - path;
if (driveNameRef != NULL) {
*driveNameRef = TclDStringToObj(&ds);
Tcl_IncrRefCount(*driveNameRef);
}
}
Tcl_DStringFree(&ds);
break;
}
}
return type;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
489 490 491 492 493 494 495 |
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclpNativeSplitPath(
Tcl_Obj *pathPtr, /* Path to split. */
| | | 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 |
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclpNativeSplitPath(
Tcl_Obj *pathPtr, /* Path to split. */
size_t *lenPtr) /* int to store number of path elements. */
{
Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */
/*
* Perform platform specific splitting.
*/
|
| ︙ | ︙ | |||
512 513 514 515 516 517 518 |
}
/*
* Compute the number of elements in the result.
*/
if (lenPtr != NULL) {
| | | 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 |
}
/*
* Compute the number of elements in the result.
*/
if (lenPtr != NULL) {
TclListObjLengthM(NULL, resultPtr, lenPtr);
}
return resultPtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
542 543 544 545 546 547 548 549 550 551 |
*
* Side effects:
* Allocates memory.
*
*----------------------------------------------------------------------
*/
void
Tcl_SplitPath(
const char *path, /* Pointer to string containing a path. */
| > | < | | 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 |
*
* Side effects:
* Allocates memory.
*
*----------------------------------------------------------------------
*/
#undef Tcl_SplitPath
void
Tcl_SplitPath(
const char *path, /* Pointer to string containing a path. */
size_t *argcPtr, /* Pointer to location to fill in with the
* number of elements in the path. */
const char ***argvPtr) /* Pointer to place to store pointer to array
* of pointers to path elements. */
{
Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */
Tcl_Obj *tmpPtr, *eltPtr;
size_t i, size, len;
char *p;
const char *str;
/*
* Perform the splitting, using objectified, vfs-aware code.
*/
|
| ︙ | ︙ | |||
681 682 683 684 685 686 687 |
Tcl_ListObjAppendElement(NULL, result, rootElt);
while (*path == '/') {
++path;
}
}
/*
| | < < < < < | < | | 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 |
Tcl_ListObjAppendElement(NULL, result, rootElt);
while (*path == '/') {
++path;
}
}
/*
* Split on slashes.
*/
for (;;) {
elementStart = path;
while ((*path != '\0') && (*path != '/')) {
path++;
}
length = path - elementStart;
if (length > 0) {
Tcl_Obj *nextElt;
nextElt = Tcl_NewStringObj(elementStart, length);
Tcl_ListObjAppendElement(NULL, result, nextElt);
}
if (*path++ == '\0') {
break;
}
}
return result;
}
|
| ︙ | ︙ | |||
749 750 751 752 753 754 755 |
if (p != path) {
Tcl_ListObjAppendElement(NULL, result, TclDStringToObj(&buf));
}
Tcl_DStringFree(&buf);
/*
| | < < | | | | | 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 |
if (p != path) {
Tcl_ListObjAppendElement(NULL, result, TclDStringToObj(&buf));
}
Tcl_DStringFree(&buf);
/*
* Split on slashes.
*/
do {
elementStart = p;
while ((*p != '\0') && (*p != '/') && (*p != '\\')) {
p++;
}
length = p - elementStart;
if (length > 0) {
Tcl_Obj *nextElt;
if ((elementStart != path) &&
isalpha(UCHAR(elementStart[0])) &&
(elementStart[1] == ':')) {
TclNewLiteralStringObj(nextElt, "./");
Tcl_AppendToObj(nextElt, elementStart, length);
} else {
nextElt = Tcl_NewStringObj(elementStart, length);
}
Tcl_ListObjAppendElement(NULL, result, nextElt);
}
} while (*p++ != '\0');
|
| ︙ | ︙ | |||
803 804 805 806 807 808 809 |
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSJoinToPath(
Tcl_Obj *pathPtr, /* Valid path or NULL. */
| | | | 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 |
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSJoinToPath(
Tcl_Obj *pathPtr, /* Valid path or NULL. */
size_t objc, /* Number of array elements to join */
Tcl_Obj *const objv[]) /* Path elements to join. */
{
if (pathPtr == NULL) {
return TclJoinPath(objc, objv, 0);
}
if (objc == 0) {
return TclJoinPath(1, &pathPtr, 0);
}
if (objc == 1) {
Tcl_Obj *pair[2];
pair[0] = pathPtr;
pair[1] = objv[0];
return TclJoinPath(2, pair, 0);
} else {
size_t elemc = objc + 1;
Tcl_Obj *ret, **elemv = (Tcl_Obj**)Tcl_Alloc(elemc*sizeof(Tcl_Obj *));
elemv[0] = pathPtr;
memcpy(elemv+1, objv, objc*sizeof(Tcl_Obj *));
ret = TclJoinPath(elemc, elemv, 0);
Tcl_Free(elemv);
return ret;
|
| ︙ | ︙ | |||
860 861 862 863 864 865 866 |
char *dest;
const char *p;
const char *start;
start = Tcl_GetStringFromObj(prefix, &length);
/*
| | | > | > | | | 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 |
char *dest;
const char *p;
const char *start;
start = Tcl_GetStringFromObj(prefix, &length);
/*
* Remove the ./ from drive-letter prefixed
* elements on Windows, unless it is the first component.
*/
p = joining;
if (length != 0) {
if ((p[0] == '.') &&
(p[1] == '/') &&
(tclPlatform==TCL_PLATFORM_WINDOWS) &&
isalpha(UCHAR(p[2])) &&
(p[3] == ':')) {
p += 2;
}
}
if (*p == '\0') {
return;
}
switch (tclPlatform) {
|
| ︙ | ︙ | |||
972 973 974 975 976 977 978 | * Modifies the Tcl_DString. * *---------------------------------------------------------------------- */ char * Tcl_JoinPath( | | < | | 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 |
* Modifies the Tcl_DString.
*
*----------------------------------------------------------------------
*/
char *
Tcl_JoinPath(
size_t argc,
const char *const *argv,
Tcl_DString *resultPtr) /* Pointer to previously initialized DString */
{
size_t i, len;
Tcl_Obj *listObj;
Tcl_Obj *resultObj;
const char *resultStr;
/*
* Build the list of paths.
*/
|
| ︙ | ︙ | |||
1022 1023 1024 1025 1026 1027 1028 | /* *--------------------------------------------------------------------------- * * Tcl_TranslateFileName -- * * Converts a file name into a form usable by the native system | | < < | > | | < < < | | 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 |
/*
*---------------------------------------------------------------------------
*
* Tcl_TranslateFileName --
*
* Converts a file name into a form usable by the native system
* interfaces.
*
* Results:
* The return value is a pointer to a string containing the name.
* This may either be the name pointer passed in or space allocated in
* bufferPtr. In all cases, if the return value is not NULL, the caller
* must call Tcl_DStringFree() to free the space. If there was an
* error in processing the name, then an error message is left in the
* interp's result (if interp was not NULL) and the return value is NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
char *
Tcl_TranslateFileName(
Tcl_Interp *interp, /* Interpreter in which to store error message
* (if necessary). */
const char *name, /* File name, which may begin with "~" (to
* indicate current user's home directory) or
* "~<user>" (to indicate any user's home
* directory). */
Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with
* name. */
{
Tcl_Obj *path = Tcl_NewStringObj(name, -1);
Tcl_Obj *transPtr;
Tcl_IncrRefCount(path);
transPtr = Tcl_FSGetTranslatedPath(interp, path);
if (transPtr == NULL) {
|
| ︙ | ︙ | |||
1146 1147 1148 1149 1150 1151 1152 |
return p;
}
/*
*----------------------------------------------------------------------
*
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | > | 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 |
return p;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GlobObjCmd --
*
* This procedure is invoked to process the "glob" Tcl command. See the
* user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GlobObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, globFlags, join, dir, result;
size_t length;
char *string;
const char *separators;
Tcl_Obj *typePtr, *look;
Tcl_Obj *pathOrDir = NULL;
Tcl_DString prefix;
static const char *const options[] = {
"-directory", "-join", "-nocomplain", "-path", "-tails",
|
| ︙ | ︙ | |||
1330 1331 1332 1333 1334 1335 1336 |
if (i == (objc-1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-types\"", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
return TCL_ERROR;
}
typePtr = objv[i+1];
| | | 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 |
if (i == (objc-1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-types\"", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
return TCL_ERROR;
}
typePtr = objv[i+1];
if (TclListObjLengthM(interp, typePtr, &length) != TCL_OK) {
return TCL_ERROR;
}
i++;
break;
case GLOB_LAST: /* -- */
i++;
goto endOfForLoop;
|
| ︙ | ︙ | |||
1452 1453 1454 1455 1456 1457 1458 |
if (typePtr != NULL) {
/*
* The rest of the possible type arguments (except 'd') are platform
* specific. We don't complain when they are used on an incompatible
* platform.
*/
| | | | | 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 |
if (typePtr != NULL) {
/*
* The rest of the possible type arguments (except 'd') are platform
* specific. We don't complain when they are used on an incompatible
* platform.
*/
TclListObjLengthM(interp, typePtr, &length);
if (length == 0) {
goto skipTypes;
}
globTypes = (Tcl_GlobTypeData *)TclStackAlloc(interp, sizeof(Tcl_GlobTypeData));
globTypes->type = 0;
globTypes->perm = 0;
globTypes->macType = NULL;
globTypes->macCreator = NULL;
while (length-- > 0) {
size_t len;
const char *str;
Tcl_ListObjIndex(interp, typePtr, length, &look);
str = Tcl_GetStringFromObj(look, &len);
if (strcmp("readonly", str) == 0) {
globTypes->perm |= TCL_GLOB_PERM_RONLY;
|
| ︙ | ︙ | |||
1521 1522 1523 1524 1525 1526 1527 |
goto badMacTypesArg;
}
globTypes->macType = look;
Tcl_IncrRefCount(look);
} else {
Tcl_Obj *item;
| | | | 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 |
goto badMacTypesArg;
}
globTypes->macType = look;
Tcl_IncrRefCount(look);
} else {
Tcl_Obj *item;
size_t llen;
if ((TclListObjLengthM(NULL, look, &llen) == TCL_OK)
&& (llen == 3)) {
Tcl_ListObjIndex(interp, look, 0, &item);
if (!strcmp("macintosh", TclGetString(item))) {
Tcl_ListObjIndex(interp, look, 1, &item);
if (!strcmp("type", TclGetString(item))) {
Tcl_ListObjIndex(interp, look, 2, &item);
if (globTypes->macType != NULL) {
|
| ︙ | ︙ | |||
1630 1631 1632 1633 1634 1635 1636 |
result = TCL_ERROR;
goto endOfGlob;
}
}
}
if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) {
| | | 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 |
result = TCL_ERROR;
goto endOfGlob;
}
}
}
if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) {
if (TclListObjLengthM(interp, Tcl_GetObjResult(interp),
&length) != TCL_OK) {
/*
* This should never happen. Maybe we should be more dramatic.
*/
result = TCL_ERROR;
goto endOfGlob;
|
| ︙ | ︙ | |||
1688 1689 1690 1691 1692 1693 1694 | } /* *---------------------------------------------------------------------- * * TclGlob -- * | | < | 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 | } /* *---------------------------------------------------------------------- * * TclGlob -- * * Sets the separator string based on the platform and calls DoGlob. * * The interpreter's result, on entry to this function, must be a valid * Tcl list (e.g. it could be empty), since we will lappend any new * results to that list. If it is not a valid list, this function will * fail to do anything very meaningful. * * Note that if globFlags contains 'TCL_GLOBMODE_TAILS' then pathPrefix |
| ︙ | ︙ | |||
1725 1726 1727 1728 1729 1730 1731 |
Tcl_Obj *pathPrefix, /* Path prefix to glob pattern, if non-null,
* which is considered literally. */
int globFlags, /* Stores or'ed combination of flags */
Tcl_GlobTypeData *types) /* Struct containing acceptable types. May be
* NULL. */
{
const char *separators;
| < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < | < < | < < < < < | 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 |
Tcl_Obj *pathPrefix, /* Path prefix to glob pattern, if non-null,
* which is considered literally. */
int globFlags, /* Stores or'ed combination of flags */
Tcl_GlobTypeData *types) /* Struct containing acceptable types. May be
* NULL. */
{
const char *separators;
char *tail;
int result;
Tcl_Obj *filenamesObj, *savedResultObj;
separators = NULL;
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
separators = "/";
break;
case TCL_PLATFORM_WINDOWS:
separators = "/\\:";
break;
}
if (pathPrefix != NULL) {
Tcl_IncrRefCount(pathPrefix);
}
tail = pattern;
/*
* Handling empty path prefixes with glob patterns like 'C:' or
* 'c:////////' is a pain on Windows if we leave it too late, since these
* aren't really patterns at all! We therefore check the head of the
* pattern now for such cases, if we don't have an unquoted prefix yet.
*
|
| ︙ | ︙ | |||
1832 1833 1834 1835 1836 1837 1838 |
}
p++;
}
tail = p;
Tcl_IncrRefCount(pathPrefix);
} else if (pathPrefix == NULL && (tail[0] == '/'
|| (tail[0] == '\\' && tail[1] == '\\'))) {
| | | 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 |
}
p++;
}
tail = p;
Tcl_IncrRefCount(pathPrefix);
} else if (pathPrefix == NULL && (tail[0] == '/'
|| (tail[0] == '\\' && tail[1] == '\\'))) {
size_t driveNameLen;
Tcl_Obj *driveName;
Tcl_Obj *temp = Tcl_NewStringObj(tail, -1);
Tcl_IncrRefCount(temp);
switch (TclGetPathType(temp, NULL, &driveNameLen, &driveName)) {
case TCL_PATH_VOLUME_RELATIVE: {
/*
|
| ︙ | ︙ | |||
1900 1901 1902 1903 1904 1905 1906 |
/*
* Finally if we still haven't managed to generate a path prefix, check if
* the path starts with a current volume.
*/
if (pathPrefix == NULL) {
| | | | 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 |
/*
* Finally if we still haven't managed to generate a path prefix, check if
* the path starts with a current volume.
*/
if (pathPrefix == NULL) {
size_t driveNameLen;
Tcl_Obj *driveName;
if (TclFSNonnativePathType(tail, strlen(tail), NULL,
&driveNameLen, &driveName) == TCL_PATH_ABSOLUTE) {
pathPrefix = driveName;
tail += driveNameLen;
}
}
/*
|
| ︙ | ︙ | |||
1985 1986 1987 1988 1989 1990 1991 |
* that would add a lot of complexity to the code. This way is a little
* slower (when the -tails flag is given), but much simpler to code.
*
* We do it by rewriting the result list in-place.
*/
if (globFlags & TCL_GLOBMODE_TAILS) {
| | | 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 |
* that would add a lot of complexity to the code. This way is a little
* slower (when the -tails flag is given), but much simpler to code.
*
* We do it by rewriting the result list in-place.
*/
if (globFlags & TCL_GLOBMODE_TAILS) {
size_t objc, i;
Tcl_Obj **objv;
size_t prefixLen;
const char *pre;
/*
* If this length has never been set, set it here.
*/
|
| ︙ | ︙ | |||
2013 2014 2015 2016 2017 2018 2019 |
if ((tclPlatform != TCL_PLATFORM_WINDOWS) || (prefixLen != 2)
|| (pre[1] != ':')) {
prefixLen++;
}
}
| | | 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 |
if ((tclPlatform != TCL_PLATFORM_WINDOWS) || (prefixLen != 2)
|| (pre[1] != ':')) {
prefixLen++;
}
}
TclListObjGetElementsM(NULL, filenamesObj, &objc, &objv);
for (i = 0; i< objc; i++) {
size_t len;
const char *oldStr = Tcl_GetStringFromObj(objv[i], &len);
Tcl_Obj *elem;
if (len == prefixLen) {
if ((pattern[0] == '\0')
|
| ︙ | ︙ | |||
2339 2340 2341 2342 2343 2344 2345 |
*p = '\0';
TclNewObj(subdirsPtr);
Tcl_IncrRefCount(subdirsPtr);
result = Tcl_FSMatchInDirectory(interp, subdirsPtr, pathPtr,
pattern, &dirOnly);
*p = save;
if (result == TCL_OK) {
| | | < < < < < < < | | | | | | 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 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 |
*p = '\0';
TclNewObj(subdirsPtr);
Tcl_IncrRefCount(subdirsPtr);
result = Tcl_FSMatchInDirectory(interp, subdirsPtr, pathPtr,
pattern, &dirOnly);
*p = save;
if (result == TCL_OK) {
size_t i, subdirc, repair = TCL_INDEX_NONE;
Tcl_Obj **subdirv;
result = TclListObjGetElementsM(interp, subdirsPtr,
&subdirc, &subdirv);
for (i=0; result==TCL_OK && i<subdirc; i++) {
Tcl_Obj *copy = NULL;
result = DoGlob(interp, matchesObj, separators, subdirv[i],
1, p+1, types);
if (copy) {
size_t end;
Tcl_DecrRefCount(subdirv[i]);
subdirv[i] = copy;
TclListObjLengthM(NULL, matchesObj, &end);
while (repair + 1 <= end) {
const char *bytes;
size_t numBytes;
Tcl_Obj *fixme, *newObj;
Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme);
bytes = Tcl_GetStringFromObj(fixme, &numBytes);
newObj = Tcl_NewStringObj(bytes+2, numBytes-2);
Tcl_ListObjReplace(NULL, matchesObj, repair, 1,
1, &newObj);
repair++;
}
repair = TCL_INDEX_NONE;
}
}
}
TclDecrRefCount(subdirsPtr);
return result;
}
|
| ︙ | ︙ |
Changes to generic/tclFileSystem.h.
| ︙ | ︙ | |||
44 45 46 47 48 49 50 | /* * Private shared functions for use by tclIOUtil.c, tclPathObj.c and * tclFileName.c, and any platform-specific filesystem code. */ MODULE_SCOPE Tcl_PathType TclFSGetPathType(Tcl_Obj *pathPtr, const Tcl_Filesystem **filesystemPtrPtr, | | | | | | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 | /* * Private shared functions for use by tclIOUtil.c, tclPathObj.c and * tclFileName.c, and any platform-specific filesystem code. */ MODULE_SCOPE Tcl_PathType TclFSGetPathType(Tcl_Obj *pathPtr, const Tcl_Filesystem **filesystemPtrPtr, size_t *driveNameLengthPtr); MODULE_SCOPE Tcl_PathType TclFSNonnativePathType(const char *pathPtr, size_t pathLen, const Tcl_Filesystem **filesystemPtrPtr, size_t *driveNameLengthPtr, Tcl_Obj **driveNameRef); MODULE_SCOPE Tcl_PathType TclGetPathType(Tcl_Obj *pathPtr, const Tcl_Filesystem **filesystemPtrPtr, size_t *driveNameLengthPtr, Tcl_Obj **driveNameRef); MODULE_SCOPE int TclFSEpochOk(size_t filesystemEpoch); MODULE_SCOPE int TclFSCwdIsNative(void); MODULE_SCOPE Tcl_Obj * TclWinVolumeRelativeNormalize(Tcl_Interp *interp, const char *path, Tcl_Obj **useThisCwdPtr); MODULE_SCOPE Tcl_FSPathInFilesystemProc TclNativePathInFilesystem; MODULE_SCOPE Tcl_FSCreateInternalRepProc TclNativeCreateNativeRep; |
| ︙ | ︙ |
Changes to generic/tclGetDate.y.
| ︙ | ︙ | |||
957 958 959 960 961 962 963 |
}
}
int
TclClockOldscanObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
| | | 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 |
}
}
int
TclClockOldscanObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Count of parameters */
Tcl_Obj *const *objv) /* Parameters */
{
Tcl_Obj *result, *resultElement;
int yr, mo, da;
DateInfo dateInfo;
DateInfo* info = &dateInfo;
int status;
|
| ︙ | ︙ |
Changes to generic/tclHash.c.
| ︙ | ︙ | |||
655 656 657 658 659 660 661 |
*/
static Tcl_HashEntry *
AllocArrayEntry(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key to store in the hash table entry. */
{
| < < | | | < < < | 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 |
*/
static Tcl_HashEntry *
AllocArrayEntry(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key to store in the hash table entry. */
{
Tcl_HashEntry *hPtr;
TCL_HASH_TYPE count = tablePtr->keyType * sizeof(int);
TCL_HASH_TYPE size = offsetof(Tcl_HashEntry, key) + count;
if (size < sizeof(Tcl_HashEntry)) {
size = sizeof(Tcl_HashEntry);
}
hPtr = (Tcl_HashEntry *)Tcl_Alloc(size);
memcpy(hPtr->key.string, keyPtr, count);
Tcl_SetHashValue(hPtr, NULL);
return hPtr;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
697 698 699 700 701 702 703 |
*/
static int
CompareArrayKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
| < < | < < < | < < < < < < | 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 |
*/
static int
CompareArrayKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
size_t count = hPtr->tablePtr->keyType * sizeof(int);
return !memcmp(keyPtr, hPtr->key.string, count);
}
/*
*----------------------------------------------------------------------
*
* HashArrayKey --
*
|
| ︙ | ︙ | |||
777 778 779 780 781 782 783 |
size_t size, allocsize;
allocsize = size = strlen(string) + 1;
if (size < sizeof(hPtr->key)) {
allocsize = sizeof(hPtr->key);
}
hPtr = (Tcl_HashEntry *)Tcl_Alloc(offsetof(Tcl_HashEntry, key) + allocsize);
| | | 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 |
size_t size, allocsize;
allocsize = size = strlen(string) + 1;
if (size < sizeof(hPtr->key)) {
allocsize = sizeof(hPtr->key);
}
hPtr = (Tcl_HashEntry *)Tcl_Alloc(offsetof(Tcl_HashEntry, key) + allocsize);
memset(hPtr, 0, offsetof(Tcl_HashEntry, key) + allocsize);
memcpy(hPtr->key.string, string, size);
Tcl_SetHashValue(hPtr, NULL);
return hPtr;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ |
Changes to generic/tclIO.c.
| ︙ | ︙ | |||
98 99 100 101 102 103 104 |
struct Channel *writePtr; /* Pointer to output channel. */
int readFlags; /* Original read channel flags. */
int writeFlags; /* Original write channel flags. */
Tcl_WideInt toRead; /* Number of bytes to copy, or -1. */
Tcl_WideInt total; /* Total bytes transferred (written). */
Tcl_Interp *interp; /* Interp that started the copy. */
Tcl_Obj *cmdPtr; /* Command to be invoked at completion. */
| | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 |
struct Channel *writePtr; /* Pointer to output channel. */
int readFlags; /* Original read channel flags. */
int writeFlags; /* Original write channel flags. */
Tcl_WideInt toRead; /* Number of bytes to copy, or -1. */
Tcl_WideInt total; /* Total bytes transferred (written). */
Tcl_Interp *interp; /* Interp that started the copy. */
Tcl_Obj *cmdPtr; /* Command to be invoked at completion. */
size_t bufSize; /* Size of appended buffer. */
char buffer[TCLFLEXARRAY]; /* Copy buffer, this must be the last
* field. */
} CopyState;
/*
* All static variables used in this file are collected into a single instance
* of the following structure. For multi-threaded implementations, there is
|
| ︙ | ︙ | |||
121 122 123 124 125 126 127 |
/* This variable holds the list of nested
* Tcl_NotifyChannel invocations. */
ChannelState *firstCSPtr; /* List of all channels currently open,
* indexed by ChannelState, as only one
* ChannelState exists per set of stacked
* channels. */
Tcl_Channel stdinChannel; /* Static variable for the stdin channel. */
| < < < > > > | | 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 158 159 160 161 |
/* This variable holds the list of nested
* Tcl_NotifyChannel invocations. */
ChannelState *firstCSPtr; /* List of all channels currently open,
* indexed by ChannelState, as only one
* ChannelState exists per set of stacked
* channels. */
Tcl_Channel stdinChannel; /* Static variable for the stdin channel. */
Tcl_Channel stdoutChannel; /* Static variable for the stdout channel. */
Tcl_Channel stderrChannel; /* Static variable for the stderr channel. */
Tcl_Encoding binaryEncoding;
int stdinInitialized;
int stdoutInitialized;
int stderrInitialized;
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* Structure to record a close callback. One such record exists for
* each close callback registered for a channel.
*/
typedef struct CloseCallback {
Tcl_CloseProc *proc; /* The procedure to call. */
ClientData clientData; /* Arbitrary one-word data to pass
* to the callback. */
struct CloseCallback *nextPtr; /* For chaining close callbacks. */
} CloseCallback;
/*
* Static functions in this file:
*/
static ChannelBuffer * AllocChannelBuffer(size_t length);
static void PreserveChannelBuffer(ChannelBuffer *bufPtr);
static void ReleaseChannelBuffer(ChannelBuffer *bufPtr);
static int IsShared(ChannelBuffer *bufPtr);
static void ChannelFree(Channel *chanPtr);
static void ChannelTimerProc(ClientData clientData);
static int ChanRead(Channel *chanPtr, char *dst, int dstSize);
static int CheckChannelErrors(ChannelState *statePtr,
|
| ︙ | ︙ | |||
271 272 273 274 275 276 277 | * char *RemovePoint(ChannelBuffer *bufPtr) * * Returns a pointer to where characters should be removed from the * buffer. * -------------------------------------------------------------------------- */ | | | | 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 | * char *RemovePoint(ChannelBuffer *bufPtr) * * Returns a pointer to where characters should be removed from the * buffer. * -------------------------------------------------------------------------- */ #define BytesLeft(bufPtr) (((bufPtr)->nextAdded - (bufPtr)->nextRemoved)) #define SpaceLeft(bufPtr) (((bufPtr)->bufLength - (bufPtr)->nextAdded)) #define IsBufferReady(bufPtr) ((bufPtr)->nextAdded > (bufPtr)->nextRemoved) #define IsBufferEmpty(bufPtr) ((bufPtr)->nextAdded == (bufPtr)->nextRemoved) #define IsBufferFull(bufPtr) ((bufPtr) && (bufPtr)->nextAdded >= (bufPtr)->bufLength) |
| ︙ | ︙ | |||
2442 2443 2444 2445 2446 2447 2448 | * None. * *--------------------------------------------------------------------------- */ static ChannelBuffer * AllocChannelBuffer( | | | | 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 |
* None.
*
*---------------------------------------------------------------------------
*/
static ChannelBuffer *
AllocChannelBuffer(
size_t length) /* Desired length of channel buffer. */
{
ChannelBuffer *bufPtr;
size_t n;
n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING;
bufPtr = (ChannelBuffer *)Tcl_Alloc(n);
bufPtr->nextAdded = BUFFER_PADDING;
bufPtr->nextRemoved = BUFFER_PADDING;
bufPtr->bufLength = length + BUFFER_PADDING;
bufPtr->nextPtr = NULL;
|
| ︙ | ︙ | |||
2528 2529 2530 2531 2532 2533 2534 |
}
/*
* Only save buffers which have the requested buffersize for the channel.
* This is to honor dynamic changes of the buffersize made by the user.
*/
| | | 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 |
}
/*
* Only save buffers which have the requested buffersize for the channel.
* This is to honor dynamic changes of the buffersize made by the user.
*/
if ((bufPtr->bufLength) != statePtr->bufSize + BUFFER_PADDING) {
ReleaseChannelBuffer(bufPtr);
return;
}
/*
* Only save buffers for the input queue if the channel is readable.
*/
|
| ︙ | ︙ | |||
4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 |
Tcl_Encoding encoding)
{
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
char *nextNewLine = NULL;
int endEncoding, saved = 0, total = 0, flushed = 0, needNlFlush = 0;
char safe[BUFFER_PADDING];
if (srcLen) {
WillWrite(chanPtr);
}
/*
* Write the terminated escape sequence even if srcLen is 0.
*/
endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0);
if (GotFlag(statePtr, CHANNEL_LINEBUFFERED)
|| (statePtr->outputTranslation != TCL_TRANSLATE_LF)) {
nextNewLine = (char *)memchr(src, '\n', srcLen);
}
| > | | 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 |
Tcl_Encoding encoding)
{
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
char *nextNewLine = NULL;
int endEncoding, saved = 0, total = 0, flushed = 0, needNlFlush = 0;
char safe[BUFFER_PADDING];
int encodingError = 0;
if (srcLen) {
WillWrite(chanPtr);
}
/*
* Write the terminated escape sequence even if srcLen is 0.
*/
endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0);
if (GotFlag(statePtr, CHANNEL_LINEBUFFERED)
|| (statePtr->outputTranslation != TCL_TRANSLATE_LF)) {
nextNewLine = (char *)memchr(src, '\n', srcLen);
}
while (srcLen + saved + endEncoding > 0 && !encodingError) {
ChannelBuffer *bufPtr;
char *dst;
int result, srcRead, dstLen, dstWrote, srcLimit = srcLen;
if (nextNewLine) {
srcLimit = nextNewLine - src;
}
|
| ︙ | ︙ | |||
4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 |
dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL);
/*
* See chan-io-1.[89]. Tcl Bug 506297.
*/
statePtr->outputEncodingFlags &= ~TCL_ENCODING_START;
if ((result != TCL_OK) && (srcRead + dstWrote == 0)) {
/*
* We're reading from invalid/incomplete UTF-8.
*/
| > > > > > > > > > > > > > < | < < | | 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 |
dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL);
/*
* See chan-io-1.[89]. Tcl Bug 506297.
*/
statePtr->outputEncodingFlags &= ~TCL_ENCODING_START;
/*
* See io-75.2, TCL bug 6978c01b65.
* Check, if an encoding error occured and should be reported to the
* script level.
* This happens, if a written character may not be represented by the
* current output encoding and strict encoding is active.
*/
if (result == TCL_CONVERT_UNKNOWN) {
encodingError = 1;
result = TCL_OK;
}
if ((result != TCL_OK) && (srcRead + dstWrote == 0)) {
/*
* We're reading from invalid/incomplete UTF-8.
*/
encodingError = 1;
result = TCL_OK;
}
bufPtr->nextAdded += dstWrote;
src += srcRead;
srcLen -= srcRead;
total += dstWrote;
dst += dstWrote;
|
| ︙ | ︙ | |||
4456 4457 4458 4459 4460 4461 4462 |
*/
if (needNlFlush && (saved == 0 || src[-1] != '\n')) {
needNlFlush = 0;
}
}
}
| | | > > > > | 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 |
*/
if (needNlFlush && (saved == 0 || src[-1] != '\n')) {
needNlFlush = 0;
}
}
}
if (((flushed < total) && GotFlag(statePtr, CHANNEL_UNBUFFERED)) ||
(needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED))) {
if (FlushChannel(NULL, chanPtr, 0) != 0) {
return -1;
}
}
UpdateInterest(chanPtr);
if (encodingError) {
Tcl_SetErrno(EILSEQ);
return -1;
}
return total;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_Gets --
|
| ︙ | ︙ | |||
4719 4720 4721 4722 4723 4724 4725 |
}
}
break;
case TCL_TRANSLATE_AUTO:
eol = dst;
skip = 1;
if (GotFlag(statePtr, INPUT_SAW_CR)) {
| < | 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 |
}
}
break;
case TCL_TRANSLATE_AUTO:
eol = dst;
skip = 1;
if (GotFlag(statePtr, INPUT_SAW_CR)) {
if ((eol < dstEnd) && (*eol == '\n')) {
/*
* Skip the raw bytes that make up the '\n'.
*/
int rawRead;
char tmp[TCL_UTF_MAX];
|
| ︙ | ︙ | |||
4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 |
goto gotEOL;
}
}
if (*eol == '\n') {
skip++;
}
eol--;
goto gotEOL;
} else if (*eol == '\n') {
goto gotEOL;
}
}
}
if (eof != NULL) {
/*
* EOF character was seen. On EOF, leave current file position
| > > | 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 |
goto gotEOL;
}
}
if (*eol == '\n') {
skip++;
}
eol--;
ResetFlag(statePtr, INPUT_SAW_CR);
goto gotEOL;
} else if (*eol == '\n') {
ResetFlag(statePtr, INPUT_SAW_CR);
goto gotEOL;
}
}
}
if (eof != NULL) {
/*
* EOF character was seen. On EOF, leave current file position
|
| ︙ | ︙ | |||
4799 4800 4801 4802 4803 4804 4805 | * If we didn't append any bytes before encountering EOF, * caller needs to see -1. */ Tcl_SetObjLength(objPtr, oldLength); CommonGetsCleanup(chanPtr); copiedTotal = -1; | | | 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 |
* If we didn't append any bytes before encountering EOF,
* caller needs to see -1.
*/
Tcl_SetObjLength(objPtr, oldLength);
CommonGetsCleanup(chanPtr);
copiedTotal = -1;
ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR);
goto done;
}
goto gotEOL;
}
dst = dstEnd;
}
|
| ︙ | ︙ | |||
5212 5213 5214 5215 5216 5217 5218 | * None. * *--------------------------------------------------------------------------- */ static void FreeBinaryEncoding( | | | 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 |
* None.
*
*---------------------------------------------------------------------------
*/
static void
FreeBinaryEncoding(
TCL_UNUSED(void *))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->binaryEncoding != NULL) {
Tcl_FreeEncoding(tsdPtr->binaryEncoding);
tsdPtr->binaryEncoding = NULL;
}
|
| ︙ | ︙ | |||
6427 6428 6429 6430 6431 6432 6433 | * * Note that the BUFFER_PADDING (See AllocChannelBuffer) is used * to prevent exactly this situation. I.e. it should never happen. * Therefore it is ok to panic should it happen despite the * precautions. */ | | | 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 |
*
* Note that the BUFFER_PADDING (See AllocChannelBuffer) is used
* to prevent exactly this situation. I.e. it should never happen.
* Therefore it is ok to panic should it happen despite the
* precautions.
*/
if (nextPtr->nextRemoved < (size_t)srcLen) {
Tcl_Panic("Buffer Underflow, BUFFER_PADDING not enough");
}
nextPtr->nextRemoved -= srcLen;
memcpy(RemovePoint(nextPtr), src, srcLen);
RecycleBuffer(statePtr, bufPtr, 0);
statePtr->inQueueHead = nextPtr;
|
| ︙ | ︙ | |||
6921 6922 6923 6924 6925 6926 6927 |
* Saved buffers of the wrong size are squashed. This is done to honor
* dynamic changes of the buffersize made by the user.
*
* TODO: Tests to cover this.
*/
if ((bufPtr != NULL)
| | | | 6937 6938 6939 6940 6941 6942 6943 6944 6945 6946 6947 6948 6949 6950 6951 6952 6953 6954 6955 6956 6957 6958 6959 6960 6961 6962 |
* Saved buffers of the wrong size are squashed. This is done to honor
* dynamic changes of the buffersize made by the user.
*
* TODO: Tests to cover this.
*/
if ((bufPtr != NULL)
&& (bufPtr->bufLength != statePtr->bufSize + BUFFER_PADDING)) {
ReleaseChannelBuffer(bufPtr);
bufPtr = NULL;
}
if (bufPtr == NULL) {
bufPtr = AllocChannelBuffer(statePtr->bufSize);
}
bufPtr->nextPtr = NULL;
toRead = SpaceLeft(bufPtr);
assert((size_t)toRead == statePtr->bufSize);
if (statePtr->inQueueTail == NULL) {
statePtr->inQueueHead = bufPtr;
} else {
statePtr->inQueueTail->nextPtr = bufPtr;
}
statePtr->inQueueTail = bufPtr;
|
| ︙ | ︙ | |||
7572 7573 7574 7575 7576 7577 7578 |
*
*----------------------------------------------------------------------
*/
void
Tcl_SetChannelBufferSize(
Tcl_Channel chan, /* The channel whose buffer size to set. */
| | | | 7588 7589 7590 7591 7592 7593 7594 7595 7596 7597 7598 7599 7600 7601 7602 7603 7604 7605 7606 7607 7608 7609 7610 |
*
*----------------------------------------------------------------------
*/
void
Tcl_SetChannelBufferSize(
Tcl_Channel chan, /* The channel whose buffer size to set. */
size_t sz) /* The size to set. */
{
ChannelState *statePtr; /* State of real channel structure. */
/*
* Clip the buffer size to force it into the [1,1M] range
*/
if (sz < 1 || sz > (TCL_INDEX_NONE>>1)) {
sz = 1;
} else if (sz > MAX_CHANNEL_BUFFER_SIZE) {
sz = MAX_CHANNEL_BUFFER_SIZE;
}
statePtr = ((Channel *) chan)->state;
|
| ︙ | ︙ | |||
7626 7627 7628 7629 7630 7631 7632 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | 7642 7643 7644 7645 7646 7647 7648 7649 7650 7651 7652 7653 7654 7655 7656 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
size_t
Tcl_GetChannelBufferSize(
Tcl_Channel chan) /* The channel for which to find the buffer
* size. */
{
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of real channel structure. */
|
| ︙ | ︙ | |||
7678 7679 7680 7681 7682 7683 7684 |
* standard generic options. Can be NULL for
* generic options only. */
{
if (interp != NULL) {
const char *genericopt =
"blocking buffering buffersize encoding eofchar translation";
const char **argv;
| | | 7694 7695 7696 7697 7698 7699 7700 7701 7702 7703 7704 7705 7706 7707 7708 |
* standard generic options. Can be NULL for
* generic options only. */
{
if (interp != NULL) {
const char *genericopt =
"blocking buffering buffersize encoding eofchar translation";
const char **argv;
size_t argc, i;
Tcl_DString ds;
Tcl_Obj *errObj;
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, genericopt, -1);
if (optionList && (*optionList)) {
TclDStringAppendLiteral(&ds, " ");
|
| ︙ | ︙ | |||
7969 7970 7971 7972 7973 7974 7975 |
const char *newValue) /* New value for option. */
{
Channel *chanPtr = (Channel *) chan;
/* The real IO channel. */
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
size_t len; /* Length of optionName string. */
| | | 7985 7986 7987 7988 7989 7990 7991 7992 7993 7994 7995 7996 7997 7998 7999 |
const char *newValue) /* New value for option. */
{
Channel *chanPtr = (Channel *) chan;
/* The real IO channel. */
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
size_t len; /* Length of optionName string. */
size_t argc;
const char **argv;
/*
* If the channel is in the middle of a background copy, fail.
*/
if (statePtr->csPtrR || statePtr->csPtrW) {
|
| ︙ | ︙ | |||
8036 8037 8038 8039 8040 8041 8042 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -buffering: must be one of"
" full, line, or none", -1));
return TCL_ERROR;
}
return TCL_OK;
} else if (HaveOpt(7, "-buffersize")) {
| | > > > > > > > > > > | | 8052 8053 8054 8055 8056 8057 8058 8059 8060 8061 8062 8063 8064 8065 8066 8067 8068 8069 8070 8071 8072 8073 8074 8075 8076 8077 8078 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -buffering: must be one of"
" full, line, or none", -1));
return TCL_ERROR;
}
return TCL_OK;
} else if (HaveOpt(7, "-buffersize")) {
Tcl_WideInt newBufferSize;
Tcl_Obj obj;
int code;
obj.refCount = 1;
obj.bytes = (char *)newValue;
obj.length = strlen(newValue);
obj.typePtr = NULL;
code = Tcl_GetWideIntFromObj(interp, &obj, &newBufferSize);
TclFreeInternalRep(&obj);
if (code == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_SetChannelBufferSize(chan, newBufferSize);
return TCL_OK;
} else if (HaveOpt(2, "-encoding")) {
Tcl_Encoding encoding;
|
| ︙ | ︙ | |||
9008 9009 9010 9011 9012 9013 9014 | * May create a channel handler for the specified channel. * *---------------------------------------------------------------------- */ int Tcl_FileEventObjCmd( | | | 9034 9035 9036 9037 9038 9039 9040 9041 9042 9043 9044 9045 9046 9047 9048 |
* May create a channel handler for the specified channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_FileEventObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter in which the channel for which
* to create the handler is found. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Channel *chanPtr; /* The channel to create the handler for. */
ChannelState *statePtr; /* State info for channel */
|
| ︙ | ︙ | |||
10927 10928 10929 10930 10931 10932 10933 |
*----------------------------------------------------------------------
*/
static Tcl_Obj *
FixLevelCode(
Tcl_Obj *msg)
{
| | > | | 10953 10954 10955 10956 10957 10958 10959 10960 10961 10962 10963 10964 10965 10966 10967 10968 10969 10970 10971 10972 10973 10974 10975 10976 10977 10978 10979 10980 10981 10982 10983 10984 10985 |
*----------------------------------------------------------------------
*/
static Tcl_Obj *
FixLevelCode(
Tcl_Obj *msg)
{
int explicitResult, numOptions, lcn;
size_t lc;
Tcl_Obj **lv, **lvn;
int res, i, j, val, lignore, cignore;
int newlevel = -1, newcode = -1;
/* ASSERT msg != NULL */
/*
* Process the caught message.
*
* Syntax = (option value)... ?message?
*
* Bad message syntax causes a panic, because the other side uses
* Tcl_GetReturnOptions and list construction functions to marshall the
* information. Hence an error means that we've got serious breakage.
*/
res = TclListObjGetElementsM(NULL, msg, &lc, &lv);
if (res != TCL_OK) {
Tcl_Panic("Tcl_SetChannelError: bad syntax of message");
}
explicitResult = (1 == (lc % 2));
numOptions = lc - explicitResult;
|
| ︙ | ︙ |
Changes to generic/tclIO.h.
| ︙ | ︙ | |||
33 34 35 36 37 38 39 |
* struct ChannelBuffer:
*
* Buffers data being sent to or from a channel.
*/
typedef struct ChannelBuffer {
size_t refCount; /* Current uses count */
| | | | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 |
* struct ChannelBuffer:
*
* Buffers data being sent to or from a channel.
*/
typedef struct ChannelBuffer {
size_t refCount; /* Current uses count */
size_t nextAdded; /* The next position into which a character
* will be put in the buffer. */
size_t nextRemoved; /* Position of next byte to be removed from
* the buffer. */
size_t bufLength; /* How big is the buffer? */
struct ChannelBuffer *nextPtr;
/* Next buffer in chain. */
char buf[TCLFLEXARRAY]; /* Placeholder for real buffer. The real
* buffer occuppies this space + bufSize-1
* bytes. This must be the last field in the
* structure. */
} ChannelBuffer;
|
| ︙ | ︙ | |||
182 183 184 185 186 187 188 |
struct ChannelHandler *chPtr;/* List of channel handlers registered for
* this channel. */
int interestMask; /* Mask of all events this channel has
* handlers for. */
EventScriptRecord *scriptRecordPtr;
/* Chain of all scripts registered for event
* handlers ("fileevent") on this channel. */
| | | 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 |
struct ChannelHandler *chPtr;/* List of channel handlers registered for
* this channel. */
int interestMask; /* Mask of all events this channel has
* handlers for. */
EventScriptRecord *scriptRecordPtr;
/* Chain of all scripts registered for event
* handlers ("fileevent") on this channel. */
size_t bufSize; /* What size buffers to allocate? */
Tcl_TimerToken timer; /* Handle to wakeup timer for this channel. */
struct CopyState *csPtrR; /* State of background copy for which channel
* is input, or NULL. */
struct CopyState *csPtrW; /* State of background copy for which channel
* is output, or NULL. */
Channel *topChanPtr; /* Refers to topmost channel in a stack. Never
* NULL. */
|
| ︙ | ︙ |
Changes to generic/tclIOCmd.c.
| ︙ | ︙ | |||
63 64 65 66 67 68 69 | * None. * *---------------------------------------------------------------------- */ static void FinalizeIOCmdTSD( | | | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 |
* None.
*
*----------------------------------------------------------------------
*/
static void
FinalizeIOCmdTSD(
TCL_UNUSED(void *))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->stdoutObjPtr != NULL) {
Tcl_DecrRefCount(tsdPtr->stdoutObjPtr);
tsdPtr->stdoutObjPtr = NULL;
}
|
| ︙ | ︙ | |||
93 94 95 96 97 98 99 | * Produces output on a channel. * *---------------------------------------------------------------------- */ int Tcl_PutsObjCmd( | | | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 |
* Produces output on a channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_PutsObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to puts on. */
Tcl_Obj *string; /* String to write. */
Tcl_Obj *chanObjPtr = NULL; /* channel object. */
|
| ︙ | ︙ | |||
206 207 208 209 210 211 212 | * May cause output to appear on the specified channel. * *---------------------------------------------------------------------- */ int Tcl_FlushObjCmd( | | | 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 |
* May cause output to appear on the specified channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_FlushObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *chanObjPtr;
Tcl_Channel chan; /* The channel to flush on. */
int mode;
|
| ︙ | ︙ | |||
270 271 272 273 274 275 276 | * May consume input from channel. * *---------------------------------------------------------------------- */ int Tcl_GetsObjCmd( | | | | 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 |
* May consume input from channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetsObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to read from. */
size_t lineLen; /* Length of line just read. */
int mode; /* Mode in which channel is opened. */
Tcl_Obj *linePtr, *chanObjPtr;
int code = TCL_OK;
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?");
return TCL_ERROR;
|
| ︙ | ︙ | |||
299 300 301 302 303 304 305 |
TclGetString(chanObjPtr)));
return TCL_ERROR;
}
TclChannelPreserve(chan);
TclNewObj(linePtr);
lineLen = Tcl_GetsObj(chan, linePtr);
| | | | | 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 |
TclGetString(chanObjPtr)));
return TCL_ERROR;
}
TclChannelPreserve(chan);
TclNewObj(linePtr);
lineLen = Tcl_GetsObj(chan, linePtr);
if (lineLen == TCL_IO_FAILURE) {
if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
Tcl_DecrRefCount(linePtr);
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area
* and put them into the regular interpreter result. Fall back to
* the regular message if nothing was found in the bypass.
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error reading \"%s\": %s",
TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
code = TCL_ERROR;
goto done;
}
lineLen = TCL_IO_FAILURE;
}
if (objc == 3) {
if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr,
TCL_LEAVE_ERR_MSG) == NULL) {
code = TCL_ERROR;
goto done;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)((Tcl_WideUInt)(lineLen + 1U)) - 1));
} else {
Tcl_SetObjResult(interp, linePtr);
}
done:
TclChannelRelease(chan);
return code;
}
|
| ︙ | ︙ | |||
354 355 356 357 358 359 360 | * May consume input from channel. * *---------------------------------------------------------------------- */ int Tcl_ReadObjCmd( | | | | | 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 |
* May consume input from channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_ReadObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to read from. */
int newline, i; /* Discard newline at end? */
Tcl_WideInt toRead; /* How many bytes to read? */
size_t charactersRead; /* How many characters were read? */
int mode; /* Mode in which channel is opened. */
Tcl_Obj *resultPtr, *chanObjPtr;
if ((objc != 2) && (objc != 3)) {
Interp *iPtr;
argerror:
|
| ︙ | ︙ | |||
412 413 414 415 416 417 418 |
/*
* Compute how many bytes to read.
*/
toRead = -1;
if (i < objc) {
| | | | 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 |
/*
* Compute how many bytes to read.
*/
toRead = -1;
if (i < objc) {
if ((TclGetWideIntFromObj(NULL, objv[i], &toRead) != TCL_OK)
|| (toRead < 0)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected non-negative integer but got \"%s\"",
TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL);
return TCL_ERROR;
}
}
TclNewObj(resultPtr);
Tcl_IncrRefCount(resultPtr);
TclChannelPreserve(chan);
charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
if (charactersRead == TCL_IO_FAILURE) {
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area and
* put them into the regular interpreter result. Fall back to the
* regular message if nothing was found in the bypass.
*/
|
| ︙ | ︙ | |||
483 484 485 486 487 488 489 | * flush queued output. * *---------------------------------------------------------------------- */ int Tcl_SeekObjCmd( | | | 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 |
* flush queued output.
*
*----------------------------------------------------------------------
*/
int
Tcl_SeekObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to tell on. */
Tcl_WideInt offset; /* Where to seek? */
int mode; /* How to seek? */
|
| ︙ | ︙ | |||
558 559 560 561 562 563 564 | * None. * *---------------------------------------------------------------------- */ int Tcl_TellObjCmd( | | | 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 |
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_TellObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to tell on. */
Tcl_WideInt newLoc;
int code;
|
| ︙ | ︙ | |||
620 621 622 623 624 625 626 | * May discard queued input; may flush queued output. * *---------------------------------------------------------------------- */ int Tcl_CloseObjCmd( | | | 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 |
* May discard queued input; may flush queued output.
*
*----------------------------------------------------------------------
*/
int
Tcl_CloseObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to close. */
static const char *const dirOptions[] = {
"read", "write", NULL
|
| ︙ | ︙ | |||
728 729 730 731 732 733 734 | * May modify the behavior of an IO channel. * *---------------------------------------------------------------------- */ int Tcl_FconfigureObjCmd( | | | 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 |
* May modify the behavior of an IO channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_FconfigureObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *optionName, *valueName;
Tcl_Channel chan; /* The channel to set a mode on. */
int i; /* Iterate over arg-value pairs. */
|
| ︙ | ︙ | |||
803 804 805 806 807 808 809 | * specified channel has an EOF condition. * *--------------------------------------------------------------------------- */ int Tcl_EofObjCmd( | | | 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 |
* specified channel has an EOF condition.
*
*---------------------------------------------------------------------------
*/
int
Tcl_EofObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
if (objc != 2) {
|
| ︙ | ︙ | |||
842 843 844 845 846 847 848 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_ExecObjCmd( | | | 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ExecObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *resultPtr;
const char **argv; /* An array for the string arguments. Stored
* on the _Tcl_ stack. */
|
| ︙ | ︙ | |||
1009 1010 1011 1012 1013 1014 1015 | * preceeding input operation on the channel would have blocked. * *--------------------------------------------------------------------------- */ int Tcl_FblockedObjCmd( | | | 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 |
* preceeding input operation on the channel would have blocked.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FblockedObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
int mode;
|
| ︙ | ︙ | |||
1055 1056 1057 1058 1059 1060 1061 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_OpenObjCmd( | | | 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_OpenObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int pipeline, prot;
const char *modeString, *what;
Tcl_Channel chan;
|
| ︙ | ︙ | |||
1113 1114 1115 1116 1117 1118 1119 |
/*
* Open the file or create a process pipeline.
*/
if (!pipeline) {
chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot);
} else {
| | > | 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 |
/*
* Open the file or create a process pipeline.
*/
if (!pipeline) {
chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot);
} else {
int mode, seekFlag, binary;
size_t cmdObjc;
const char **cmdArgv;
if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) {
return TCL_ERROR;
}
mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary);
|
| ︙ | ︙ | |||
1281 1282 1283 1284 1285 1286 1287 |
Tcl_HashEntry *hPtr;
hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL);
if (hTblPtr == NULL) {
return;
}
| | | 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 |
Tcl_HashEntry *hPtr;
hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL);
if (hTblPtr == NULL) {
return;
}
hPtr = Tcl_FindHashEntry(hTblPtr, acceptCallbackPtr);
if (hPtr != NULL) {
Tcl_DeleteHashEntry(hPtr);
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1430 1431 1432 1433 1434 1435 1436 | * Creates a socket based channel. * *---------------------------------------------------------------------- */ int Tcl_SocketObjCmd( | | | 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 |
* Creates a socket based channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_SocketObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const socketOptions[] = {
"-async", "-myaddr", "-myport", "-reuseaddr", "-reuseport", "-server",
NULL
|
| ︙ | ︙ | |||
1672 1673 1674 1675 1676 1677 1678 | * handler. * *---------------------------------------------------------------------- */ int Tcl_FcopyObjCmd( | | | 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 |
* handler.
*
*----------------------------------------------------------------------
*/
int
Tcl_FcopyObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel inChan, outChan;
int mode, i, index;
Tcl_WideInt toRead;
|
| ︙ | ︙ | |||
1767 1768 1769 1770 1771 1772 1773 | * "output"), or -1 if the channel wasn't opened for that mode. * *--------------------------------------------------------------------------- */ static int ChanPendingObjCmd( | | | 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 |
* "output"), or -1 if the channel wasn't opened for that mode.
*
*---------------------------------------------------------------------------
*/
static int
ChanPendingObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
int mode;
static const char *const options[] = {"input", "output", NULL};
|
| ︙ | ︙ | |||
1829 1830 1831 1832 1833 1834 1835 | * Truncates a channel (or rather a file underlying a channel). * *---------------------------------------------------------------------- */ static int ChanTruncateObjCmd( | | | 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 |
* Truncates a channel (or rather a file underlying a channel).
*
*----------------------------------------------------------------------
*/
static int
ChanTruncateObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
Tcl_WideInt length;
|
| ︙ | ︙ | |||
1902 1903 1904 1905 1906 1907 1908 | * anonymous pipe. * *---------------------------------------------------------------------- */ static int ChanPipeObjCmd( | | | 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 |
* anonymous pipe.
*
*----------------------------------------------------------------------
*/
static int
ChanPipeObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel rchan, wchan;
const char *channelNames[2];
Tcl_Obj *resultPtr;
|
| ︙ | ︙ | |||
1953 1954 1955 1956 1957 1958 1959 | * None. * *---------------------------------------------------------------------- */ int TclChannelNamesCmd( | | | 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 |
* None.
*
*----------------------------------------------------------------------
*/
int
TclChannelNamesCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc < 1 || objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?pattern?");
return TCL_ERROR;
|
| ︙ | ︙ |
Changes to generic/tclIOGT.c.
| ︙ | ︙ | |||
254 255 256 257 258 259 260 |
Tcl_Interp *interp, /* Interpreter for result. */
Tcl_Channel chan, /* Channel to transform. */
Tcl_Obj *cmdObjPtr) /* Script to use for transform. */
{
Channel *chanPtr; /* The actual channel. */
ChannelState *statePtr; /* State info for channel. */
int mode; /* Read/write mode of the channel. */
| | | | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 |
Tcl_Interp *interp, /* Interpreter for result. */
Tcl_Channel chan, /* Channel to transform. */
Tcl_Obj *cmdObjPtr) /* Script to use for transform. */
{
Channel *chanPtr; /* The actual channel. */
ChannelState *statePtr; /* State info for channel. */
int mode; /* Read/write mode of the channel. */
size_t objc;
TransformChannelData *dataPtr;
Tcl_DString ds;
if (chan == NULL) {
return TCL_ERROR;
}
if (TCL_OK != TclListObjLengthM(interp, cmdObjPtr, &objc)) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("-command value is not a list", -1));
return TCL_ERROR;
}
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
|
| ︙ | ︙ |
Changes to generic/tclIORChan.c.
| ︙ | ︙ | |||
509 510 511 512 513 514 515 |
Tcl_Obj *rcId; /* Handle of the new channel */
int mode; /* R/W mode of new channel. Has to match
* abilities of handler commands */
Tcl_Obj *cmdObj; /* Command prefix, list of words */
Tcl_Obj *cmdNameObj; /* Command name */
Tcl_Channel chan; /* Token for the new channel */
Tcl_Obj *modeObj; /* mode in obj form for method call */
| | | 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 |
Tcl_Obj *rcId; /* Handle of the new channel */
int mode; /* R/W mode of new channel. Has to match
* abilities of handler commands */
Tcl_Obj *cmdObj; /* Command prefix, list of words */
Tcl_Obj *cmdNameObj; /* Command name */
Tcl_Channel chan; /* Token for the new channel */
Tcl_Obj *modeObj; /* mode in obj form for method call */
size_t listc; /* Result of 'initialize', and of */
Tcl_Obj **listv; /* its sublist in the 2nd element */
int methIndex; /* Encoded method name */
int result; /* Result code for 'initialize' */
Tcl_Obj *resObj; /* Result data for 'initialize' */
int methods; /* Bitmask for supported methods. */
Channel *chanPtr; /* 'chan' resolved to internal struct. */
Tcl_Obj *err; /* Error message */
|
| ︙ | ︙ | |||
605 606 607 608 609 610 611 |
/*
* Verify the result.
* - List, of method names. Convert to mask.
* Check for non-optionals through the mask.
* Compare open mode against optional r/w.
*/
| | | 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 |
/*
* Verify the result.
* - List, of method names. Convert to mask.
* Check for non-optionals through the mask.
* Compare open mode against optional r/w.
*/
if (TclListObjGetElementsM(NULL, resObj, &listc, &listv) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s initialize\" returned non-list: %s",
TclGetString(cmdObj), TclGetString(resObj)));
Tcl_DecrRefCount(resObj);
goto error;
}
|
| ︙ | ︙ | |||
980 981 982 983 984 985 986 |
* XXX Race condition !!
* XXX The destination thread may not exist anymore already.
* XXX (Delayed postevent executed after channel got removed).
* XXX Can we detect this ? (check the validity of the owner threadid ?)
* XXX Actually, in that case the channel should be dead also !
*/
| | | | 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 |
* XXX Race condition !!
* XXX The destination thread may not exist anymore already.
* XXX (Delayed postevent executed after channel got removed).
* XXX Can we detect this ? (check the validity of the owner threadid ?)
* XXX Actually, in that case the channel should be dead also !
*/
Tcl_ThreadQueueEvent(rcPtr->owner, (Tcl_Event *) ev,
TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY);
}
#endif
/*
* Squash interp results left by the event script.
*/
|
| ︙ | ︙ | |||
1043 1044 1045 1046 1047 1048 1049 |
}
static void
UnmarshallErrorResult(
Tcl_Interp *interp,
Tcl_Obj *msgObj)
{
| | | | | 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 |
}
static void
UnmarshallErrorResult(
Tcl_Interp *interp,
Tcl_Obj *msgObj)
{
size_t lc;
Tcl_Obj **lv;
int explicitResult;
size_t numOptions;
/*
* Process the caught message.
*
* Syntax = (option value)... ?message?
*
* Bad syntax causes a panic. This is OK because the other side uses
* Tcl_GetReturnOptions and list construction functions to marshall the
* information; if we panic here, something has gone badly wrong already.
*/
if (TclListObjGetElementsM(interp, msgObj, &lc, &lv) != TCL_OK) {
Tcl_Panic("TclChanCaughtErrorBypass: Bad syntax of caught result");
}
if (interp == NULL) {
return;
}
explicitResult = lc & 1; /* Odd number of values? */
|
| ︙ | ︙ | |||
1908 1909 1910 1911 1912 1913 1914 |
* This code is special. It has regular passing of Tcl result, and errors.
* The bypass functions are not required.
*/
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
Tcl_Obj *optionObj;
Tcl_Obj *resObj; /* Result data for 'configure' */
| > | | 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 |
* This code is special. It has regular passing of Tcl result, and errors.
* The bypass functions are not required.
*/
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
Tcl_Obj *optionObj;
Tcl_Obj *resObj; /* Result data for 'configure' */
size_t listc;
int result = TCL_OK;
Tcl_Obj **listv;
MethodName method;
/*
* Are we in the correct thread?
*/
|
| ︙ | ︙ | |||
1989 1990 1991 1992 1993 1994 1995 |
/*
* NOTE (4): If we extract the string rep we can assume a properly quoted
* string. Together with a separating space this way of simply appending
* the whole string rep might be faster. It also doesn't check if the
* result is a valid list. Nor that the list has an even number elements.
*/
| | | | 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 |
/*
* NOTE (4): If we extract the string rep we can assume a properly quoted
* string. Together with a separating space this way of simply appending
* the whole string rep might be faster. It also doesn't check if the
* result is a valid list. Nor that the list has an even number elements.
*/
if (TclListObjGetElementsM(interp, resObj, &listc, &listv) != TCL_OK) {
goto error;
}
if ((listc % 2) == 1) {
/*
* Odd number of elements is wrong.
*/
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Expected list with even number of "
"elements, got %" TCL_Z_MODIFIER "u element%s instead", listc,
(listc == 1 ? "" : "s")));
goto error;
} else {
size_t len;
const char *str = Tcl_GetStringFromObj(resObj, &len);
if (len) {
|
| ︙ | ︙ | |||
2130 2131 2132 2133 2134 2135 2136 |
EncodeEventMask(
Tcl_Interp *interp,
const char *objName,
Tcl_Obj *obj,
int *mask)
{
int events; /* Mask of events to post */
| | | | 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 |
EncodeEventMask(
Tcl_Interp *interp,
const char *objName,
Tcl_Obj *obj,
int *mask)
{
int events; /* Mask of events to post */
size_t listc; /* #elements in eventspec list */
Tcl_Obj **listv; /* Elements of eventspec list */
int evIndex; /* Id of event for an element of the eventspec
* list. */
if (TclListObjGetElementsM(interp, obj, &listc, &listv) != TCL_OK) {
return TCL_ERROR;
}
if (listc < 1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad %s list: is empty", objName));
return TCL_ERROR;
|
| ︙ | ︙ | |||
2967 2968 2969 2970 2971 2972 2973 |
Tcl_CreateThreadExitHandler(SrcExitProc, evPtr);
/*
* Queue the event and poke the other thread's notifier.
*/
| | | | 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 |
Tcl_CreateThreadExitHandler(SrcExitProc, evPtr);
/*
* Queue the event and poke the other thread's notifier.
*/
Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr,
TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY);
/*
* (*) Block until the handler thread has either processed the transfer or
* rejected it.
*/
while (resultPtr->result < 0) {
|
| ︙ | ︙ | |||
3300 3301 3302 3303 3304 3305 3306 |
ForwardSetObjError(paramPtr, resObj);
} else {
/*
* Extract list, validate that it is a list, and #elements. See
* NOTE (4) as well.
*/
| | | | | 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 |
ForwardSetObjError(paramPtr, resObj);
} else {
/*
* Extract list, validate that it is a list, and #elements. See
* NOTE (4) as well.
*/
size_t listc;
Tcl_Obj **listv;
if (TclListObjGetElementsM(interp, resObj, &listc,
&listv) != TCL_OK) {
Tcl_DecrRefCount(resObj);
resObj = MarshallError(interp);
ForwardSetObjError(paramPtr, resObj);
} else if ((listc % 2) == 1) {
/*
* Odd number of elements is wrong. [x].
*/
char *buf = (char *)Tcl_Alloc(200);
sprintf(buf,
"{Expected list with even number of elements, got %" TCL_Z_MODIFIER "u %s instead}",
listc, (listc == 1 ? "element" : "elements"));
ForwardSetDynamicError(paramPtr, buf);
} else {
size_t len;
const char *str = Tcl_GetStringFromObj(resObj, &len);
|
| ︙ | ︙ |
Changes to generic/tclIORTrans.c.
| ︙ | ︙ | |||
507 508 509 510 511 512 513 |
int mode; /* R/W mode of parent, later the new channel.
* Has to match the abilities of the handler
* commands */
Tcl_Obj *cmdObj; /* Command prefix, list of words */
Tcl_Obj *cmdNameObj; /* Command name */
Tcl_Obj *rtId; /* Handle of the new transform (channel) */
Tcl_Obj *modeObj; /* mode in obj form for method call */
| | | 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 |
int mode; /* R/W mode of parent, later the new channel.
* Has to match the abilities of the handler
* commands */
Tcl_Obj *cmdObj; /* Command prefix, list of words */
Tcl_Obj *cmdNameObj; /* Command name */
Tcl_Obj *rtId; /* Handle of the new transform (channel) */
Tcl_Obj *modeObj; /* mode in obj form for method call */
size_t listc; /* Result of 'initialize', and of */
Tcl_Obj **listv; /* its sublist in the 2nd element */
int methIndex; /* Encoded method name */
int result; /* Result code for 'initialize' */
Tcl_Obj *resObj; /* Result data for 'initialize' */
int methods; /* Bitmask for supported methods. */
ReflectedTransformMap *rtmPtr;
/* Map of reflected transforms with handlers
|
| ︙ | ︙ | |||
595 596 597 598 599 600 601 |
/*
* Verify the result.
* - List, of method names. Convert to mask. Check for non-optionals
* through the mask. Compare open mode against optional r/w.
*/
| | | 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 |
/*
* Verify the result.
* - List, of method names. Convert to mask. Check for non-optionals
* through the mask. Compare open mode against optional r/w.
*/
if (TclListObjGetElementsM(NULL, resObj, &listc, &listv) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s initialize\" returned non-list: %s",
TclGetString(cmdObj), TclGetString(resObj)));
Tcl_DecrRefCount(resObj);
goto error;
}
|
| ︙ | ︙ | |||
816 817 818 819 820 821 822 |
}
static void
UnmarshallErrorResult(
Tcl_Interp *interp,
Tcl_Obj *msgObj)
{
| | | | | 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 |
}
static void
UnmarshallErrorResult(
Tcl_Interp *interp,
Tcl_Obj *msgObj)
{
size_t lc;
Tcl_Obj **lv;
int explicitResult;
size_t numOptions;
/*
* Process the caught message.
*
* Syntax = (option value)... ?message?
*
* Bad syntax causes a panic. This is OK because the other side uses
* Tcl_GetReturnOptions and list construction functions to marshall the
* information; if we panic here, something has gone badly wrong already.
*/
if (TclListObjGetElementsM(interp, msgObj, &lc, &lv) != TCL_OK) {
Tcl_Panic("TclChanCaughtErrorBypass: Bad syntax of caught result");
}
if (interp == NULL) {
return;
}
explicitResult = lc & 1; /* Odd number of values? */
|
| ︙ | ︙ | |||
1715 1716 1717 1718 1719 1720 1721 |
Tcl_Interp *interp,
Tcl_Obj *cmdpfxObj,
TCL_UNUSED(int) /*mode*/,
Tcl_Obj *handleObj,
Tcl_Channel parentChan)
{
ReflectedTransform *rtPtr;
| | < | 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 |
Tcl_Interp *interp,
Tcl_Obj *cmdpfxObj,
TCL_UNUSED(int) /*mode*/,
Tcl_Obj *handleObj,
Tcl_Channel parentChan)
{
ReflectedTransform *rtPtr;
size_t i, listc;
Tcl_Obj **listv;
rtPtr = (ReflectedTransform *)Tcl_Alloc(sizeof(ReflectedTransform));
/* rtPtr->chan: Assigned by caller. Dummy data here. */
/* rtPtr->methods: Assigned by caller. Dummy data here. */
rtPtr->chan = NULL;
|
| ︙ | ︙ | |||
1753 1754 1755 1756 1757 1758 1759 |
/*
* Method placeholder.
*/
/* ASSERT: cmdpfxObj is a Tcl List */
| | | 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 |
/*
* Method placeholder.
*/
/* ASSERT: cmdpfxObj is a Tcl List */
TclListObjGetElementsM(interp, cmdpfxObj, &listc, &listv);
/*
* See [==] as well.
* Storage for the command prefix and the additional words required for
* the invocation of methods in the command handler.
*
* listv [0] [listc-1] | [listc] [listc+1] |
|
| ︙ | ︙ | |||
2411 2412 2413 2414 2415 2416 2417 |
Tcl_CreateThreadExitHandler(SrcExitProc, evPtr);
/*
* Queue the event and poke the other thread's notifier.
*/
| | | | 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 |
Tcl_CreateThreadExitHandler(SrcExitProc, evPtr);
/*
* Queue the event and poke the other thread's notifier.
*/
Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr,
TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY);
/*
* (*) Block until the other thread has either processed the transfer or
* rejected it.
*/
while (resultPtr->result < 0) {
|
| ︙ | ︙ |
Changes to generic/tclIOUtil.c.
| ︙ | ︙ | |||
985 986 987 988 989 990 991 |
* of the correct type. */
Tcl_GlobTypeData *types) /* Specifies acceptable types.
* May be NULL. The directory flag is
* particularly significant. */
{
const Tcl_Filesystem *fsPtr;
Tcl_Obj *cwd, *tmpResultPtr, **elemsPtr;
| | > | 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 |
* of the correct type. */
Tcl_GlobTypeData *types) /* Specifies acceptable types.
* May be NULL. The directory flag is
* particularly significant. */
{
const Tcl_Filesystem *fsPtr;
Tcl_Obj *cwd, *tmpResultPtr, **elemsPtr;
size_t resLength, i;
int ret = -1;
if (types != NULL && (types->type & TCL_GLOB_TYPE_MOUNT)) {
/*
* Currently external callers may not query mounts, which would be a
* valuable future step. This is the only routine that knows about
* mounts, so we're being called recursively by ourself. Return no
* matches.
|
| ︙ | ︙ | |||
1061 1062 1063 1064 1065 1066 1067 |
if (ret == TCL_OK) {
FsAddMountsToGlobResult(tmpResultPtr, cwd, pattern, types);
/*
* resultPtr and tmpResultPtr are guaranteed to be distinct.
*/
| | | 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 |
if (ret == TCL_OK) {
FsAddMountsToGlobResult(tmpResultPtr, cwd, pattern, types);
/*
* resultPtr and tmpResultPtr are guaranteed to be distinct.
*/
ret = TclListObjGetElementsM(interp, tmpResultPtr,
&resLength, &elemsPtr);
for (i=0 ; ret==TCL_OK && i<resLength ; i++) {
ret = Tcl_ListObjAppendElement(interp, resultPtr,
TclFSMakePathRelative(interp, elemsPtr[i], cwd));
}
}
TclDecrRefCount(tmpResultPtr);
|
| ︙ | ︙ | |||
1101 1102 1103 1104 1105 1106 1107 |
* not be shared. */
Tcl_Obj *pathPtr, /* The directory that was searched. */
const char *pattern, /* Pattern to match mounts against. */
Tcl_GlobTypeData *types) /* Acceptable types. May be NULL. The
* directory flag is particularly significant.
*/
{
| | | | | | 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 |
* not be shared. */
Tcl_Obj *pathPtr, /* The directory that was searched. */
const char *pattern, /* Pattern to match mounts against. */
Tcl_GlobTypeData *types) /* Acceptable types. May be NULL. The
* directory flag is particularly significant.
*/
{
size_t mLength, gLength, i;
int dir = (types == NULL || (types->type & TCL_GLOB_TYPE_DIR));
Tcl_Obj *mounts = FsListMounts(pathPtr, pattern);
if (mounts == NULL) {
return;
}
if (TclListObjLengthM(NULL, mounts, &mLength) != TCL_OK || mLength == 0) {
goto endOfMounts;
}
if (TclListObjLengthM(NULL, resultPtr, &gLength) != TCL_OK) {
goto endOfMounts;
}
for (i=0 ; i<mLength ; i++) {
Tcl_Obj *mElt;
size_t j;
int found = 0;
Tcl_ListObjIndex(NULL, mounts, i, &mElt);
for (j=0 ; j<gLength ; j++) {
Tcl_Obj *gElt;
|
| ︙ | ︙ | |||
1208 1209 1210 1211 1212 1213 1214 | * (2) An additional mount point is established inside an existing * filesystem (except for the native file system; see note below). * * (3) A filesystem changes the list of available volumes (except for the * native file system; see note below). * * (4) The mapping from a string representation of a file to a full, | | < < | 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 | * (2) An additional mount point is established inside an existing * filesystem (except for the native file system; see note below). * * (3) A filesystem changes the list of available volumes (except for the * native file system; see note below). * * (4) The mapping from a string representation of a file to a full, * normalized pathname changes. * * Tcl has no control over (2) and (3), so each registered filesystem must * call Tcl_FSMountsChnaged in each of those circumstances. * * The reason for the exception in 2,3 for the native filesystem is that * the native filesystem claims every file without determining whether * whether the file exists, or even whether the pathname makes sense. |
| ︙ | ︙ | |||
1471 1472 1473 1474 1475 1476 1477 |
const char *modeString, /* Mode string, e.g. "r+" or "RDONLY CREAT" */
int *seekFlagPtr, /* Sets this to 1 to tell the the caller to seek to
* EOF after opening the file, and 0 otherwise. */
int *binaryPtr) /* Sets this to 1 to tell the caller to
* configure the channel for binary
* operations after opening the file. */
{
| | > | 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 |
const char *modeString, /* Mode string, e.g. "r+" or "RDONLY CREAT" */
int *seekFlagPtr, /* Sets this to 1 to tell the the caller to seek to
* EOF after opening the file, and 0 otherwise. */
int *binaryPtr) /* Sets this to 1 to tell the caller to
* configure the channel for binary
* operations after opening the file. */
{
int mode, c, gotRW;
size_t modeArgc, i;
const char **modeArgv, *flag;
#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)
/*
* Check for the simpler fopen-like access modes like "r" which are
* distinguished from the POSIX access modes by the presence of a
* lower-case first letter.
|
| ︙ | ︙ | |||
2470 2471 2472 2473 2474 2475 2476 |
}
return result;
} else if (listObj != NULL) {
/*
* It's a non-constant attribute list, so do a literal search.
*/
| | | | 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 |
}
return result;
} else if (listObj != NULL) {
/*
* It's a non-constant attribute list, so do a literal search.
*/
size_t i, objc;
Tcl_Obj **objv;
if (TclListObjGetElementsM(NULL, listObj, &objc, &objv) != TCL_OK) {
TclDecrRefCount(listObj);
return TCL_ERROR;
}
for (i=0 ; i<objc ; i++) {
if (!strcmp(attributeName, TclGetString(objv[i]))) {
TclDecrRefCount(listObj);
*indexPtr = i;
|
| ︙ | ︙ | |||
3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 |
*
* Side effects:
* If lenPtr is not null, sets it to the number of elements in the result.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSSplitPath(
Tcl_Obj *pathPtr, /* The pathname to split. */
| > | | | 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 |
*
* Side effects:
* If lenPtr is not null, sets it to the number of elements in the result.
*
*---------------------------------------------------------------------------
*/
#undef Tcl_FSSplitPath
Tcl_Obj *
Tcl_FSSplitPath(
Tcl_Obj *pathPtr, /* The pathname to split. */
size_t *lenPtr) /* A place to hold the number of pathname
* elements. */
{
Tcl_Obj *result = NULL; /* Just to squelch gcc warnings. */
const Tcl_Filesystem *fsPtr;
char separator = '/';
size_t driveNameLength;
const char *p;
/*
* Perform platform-specific splitting.
*/
if (TclFSGetPathType(pathPtr, &fsPtr,
|
| ︙ | ︙ | |||
3923 3924 3925 3926 3927 3928 3929 |
/*
* Add the remaining pathname elements to the list.
*/
for (;;) {
const char *elementStart = p;
| | < < < < < | < | | | 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 3952 3953 3954 3955 |
/*
* Add the remaining pathname elements to the list.
*/
for (;;) {
const char *elementStart = p;
size_t length;
while ((*p != '\0') && (*p != separator)) {
p++;
}
length = p - elementStart;
if (length > 0) {
Tcl_Obj *nextElt;
nextElt = Tcl_NewStringObj(elementStart, length);
Tcl_ListObjAppendElement(NULL, result, nextElt);
}
if (*p++ == '\0') {
break;
}
}
if (lenPtr != NULL) {
TclListObjLengthM(NULL, result, lenPtr);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* TclGetPathType --
|
| ︙ | ︙ | |||
3974 3975 3976 3977 3978 3979 3980 |
Tcl_PathType
TclGetPathType(
Tcl_Obj *pathPtr, /* Pathname to determine type of. */
const Tcl_Filesystem **filesystemPtrPtr,
/* If not NULL, a place in which to store a
* pointer to the filesystem for this pathname
* if it is absolute. */
| | | 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 |
Tcl_PathType
TclGetPathType(
Tcl_Obj *pathPtr, /* Pathname to determine type of. */
const Tcl_Filesystem **filesystemPtrPtr,
/* If not NULL, a place in which to store a
* pointer to the filesystem for this pathname
* if it is absolute. */
size_t *driveNameLengthPtr, /* If not NULL, a place in which to store the
* length of the volume name. */
Tcl_Obj **driveNameRef) /* If not NULL, for an absolute pathname, a
* place to store a pointer to an object with a
* refCount of 1, and whose value is the name
* of the volume. */
{
size_t pathLen;
|
| ︙ | ︙ | |||
4023 4024 4025 4026 4027 4028 4029 |
*
*----------------------------------------------------------------------
*/
Tcl_PathType
TclFSNonnativePathType(
const char *path, /* Pathname to determine the type of. */
| | | | 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 |
*
*----------------------------------------------------------------------
*/
Tcl_PathType
TclFSNonnativePathType(
const char *path, /* Pathname to determine the type of. */
size_t pathLen, /* Length of the pathname. */
const Tcl_Filesystem **filesystemPtrPtr,
/* If not NULL, a place to store a pointer to
* the filesystem for this pathname when it is
* an absolute pathname. */
size_t *driveNameLengthPtr, /* If not NULL, a place to store the length of
* the volume name if the pathname is absolute.
*/
Tcl_Obj **driveNameRef) /* If not NULL, a place to store a pointer to
* an object having its its refCount already
* incremented, and contining the name of the
* volume if the pathname is absolute. */
{
|
| ︙ | ︙ | |||
4065 4066 4067 4068 4069 4070 4071 |
* no reason to waste time doing that in this frequently-called
* function. It is better to save the overhead of the native
* filesystem continuously returning a list of volumes.
*/
if ((fsRecPtr->fsPtr != &tclNativeFilesystem)
&& (fsRecPtr->fsPtr->listVolumesProc != NULL)) {
| | | | | | | 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 |
* no reason to waste time doing that in this frequently-called
* function. It is better to save the overhead of the native
* filesystem continuously returning a list of volumes.
*/
if ((fsRecPtr->fsPtr != &tclNativeFilesystem)
&& (fsRecPtr->fsPtr->listVolumesProc != NULL)) {
size_t numVolumes;
Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc();
if (thisFsVolumes != NULL) {
if (TclListObjLengthM(NULL, thisFsVolumes, &numVolumes)
!= TCL_OK) {
/*
* This is VERY bad; the listVolumesProc didn't return a
* valid list. Set numVolumes to -1 to skip the loop below
* and just return with the current value of 'type'.
*
* It would be better to signal an error here, but
* Tcl_Panic seems a bit excessive.
*/
numVolumes = TCL_INDEX_NONE;
}
while (numVolumes + 1 > 1) {
Tcl_Obj *vol;
size_t len;
const char *strVol;
numVolumes--;
Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol);
strVol = Tcl_GetStringFromObj(vol,&len);
if (pathLen < len) {
continue;
}
if (strncmp(strVol, path, len) == 0) {
type = TCL_PATH_ABSOLUTE;
if (filesystemPtrPtr != NULL) {
*filesystemPtrPtr = fsRecPtr->fsPtr;
}
|
| ︙ | ︙ |
Changes to generic/tclIndexObj.c.
| ︙ | ︙ | |||
108 109 110 111 112 113 114 |
* value of objPtr. */
const char *msg, /* Identifying word to use in error
* messages. */
int flags, /* 0 or TCL_EXACT */
int *indexPtr) /* Place to store resulting integer index. */
{
| | > | | 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 |
* value of objPtr. */
const char *msg, /* Identifying word to use in error
* messages. */
int flags, /* 0 or TCL_EXACT */
int *indexPtr) /* Place to store resulting integer index. */
{
size_t objc, t;
int result;
Tcl_Obj **objv;
const char **tablePtr;
/*
* Use Tcl_GetIndexFromObjStruct to do the work to avoid duplicating most
* of the code there. This is a bit ineffiecient but simpler.
*/
result = TclListObjGetElementsM(interp, tableObjPtr, &objc, &objv);
if (result != TCL_OK) {
return result;
}
/*
* Build a string table from the list.
*/
|
| ︙ | ︙ | |||
359 360 361 362 363 364 365 |
Tcl_SetObjResult(interp, resultPtr);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL);
}
return TCL_ERROR;
}
/* #define again, needed below */
#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \
| | | 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 |
Tcl_SetObjResult(interp, resultPtr);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL);
}
return TCL_ERROR;
}
/* #define again, needed below */
#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \
((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr)))
/*
*----------------------------------------------------------------------
*
* UpdateStringOfIndex --
*
* This function is called to convert a Tcl object from index internal
|
| ︙ | ︙ | |||
504 505 506 507 508 509 510 |
static int
PrefixMatchObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 |
static int
PrefixMatchObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int flags = 0, result, dummy, i;
size_t dummyLength, errorLength;
Tcl_Obj *errorPtr = NULL;
const char *message = "option";
Tcl_Obj *tablePtr, *objPtr, *resultPtr;
static const char *const matchOptions[] = {
"-error", "-exact", "-message", NULL
};
enum matchOptionsEnum {
|
| ︙ | ︙ | |||
548 549 550 551 552 553 554 |
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing value for -error", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
return TCL_ERROR;
}
i++;
| | | 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 |
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing value for -error", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
return TCL_ERROR;
}
i++;
result = TclListObjLengthM(interp, objv[i], &errorLength);
if (result != TCL_OK) {
return TCL_ERROR;
}
if ((errorLength % 2) != 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"error options must have an even number of elements",
-1));
|
| ︙ | ︙ | |||
572 573 574 575 576 577 578 |
objPtr = objv[objc - 1];
/*
* Check that table is a valid list first, since we want to handle that
* error case regardless of level.
*/
| | | 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 |
objPtr = objv[objc - 1];
/*
* Check that table is a valid list first, since we want to handle that
* error case regardless of level.
*/
result = TclListObjLengthM(interp, tablePtr, &dummyLength);
if (result != TCL_OK) {
return result;
}
result = GetIndexFromObjList(interp, objPtr, tablePtr, message, flags,
&dummy);
if (result != TCL_OK) {
|
| ︙ | ︙ | |||
628 629 630 631 632 633 634 |
static int
PrefixAllObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | | 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 |
static int
PrefixAllObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int result;
size_t length, elemLength, tableObjc, t;
const char *string, *elemString;
Tcl_Obj **tableObjv, *resultPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "table string");
return TCL_ERROR;
}
result = TclListObjGetElementsM(interp, objv[1], &tableObjc, &tableObjv);
if (result != TCL_OK) {
return result;
}
resultPtr = Tcl_NewListObj(0, NULL);
string = Tcl_GetStringFromObj(objv[2], &length);
for (t = 0; t < tableObjc; t++) {
|
| ︙ | ︙ | |||
686 687 688 689 690 691 692 |
static int
PrefixLongestObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | | 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 |
static int
PrefixLongestObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int result;
size_t i, length, elemLength, resultLength, tableObjc, t;
const char *string, *elemString, *resultString;
Tcl_Obj **tableObjv;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "table string");
return TCL_ERROR;
}
result = TclListObjGetElementsM(interp, objv[1], &tableObjc, &tableObjv);
if (result != TCL_OK) {
return result;
}
string = Tcl_GetStringFromObj(objv[2], &length);
resultString = NULL;
resultLength = 0;
|
| ︙ | ︙ | |||
802 803 804 805 806 807 808 |
*
*----------------------------------------------------------------------
*/
void
Tcl_WrongNumArgs(
Tcl_Interp *interp, /* Current interpreter. */
| | < | | | | 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 |
*
*----------------------------------------------------------------------
*/
void
Tcl_WrongNumArgs(
Tcl_Interp *interp, /* Current interpreter. */
size_t objc, /* Number of arguments to print from objv. */
Tcl_Obj *const objv[], /* Initial argument objects, which should be
* included in the error message. */
const char *message) /* Error message to print after the leading
* objects in objv. The message may be
* NULL. */
{
Tcl_Obj *objPtr;
size_t i, len, elemLen;
char flags;
Interp *iPtr = (Interp *)interp;
const char *elementStr;
TclNewObj(objPtr);
if (iPtr->flags & INTERP_ALTERNATE_WRONG_ARGS) {
iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS;
Tcl_AppendObjToObj(objPtr, Tcl_GetObjResult(interp));
Tcl_AppendToObj(objPtr, " or \"", -1);
} else {
Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
}
/*
* If processing an an ensemble implementation, rewrite the results in
* terms of how the ensemble was invoked.
*/
if (iPtr->ensembleRewrite.sourceObjs != NULL) {
size_t toSkip = iPtr->ensembleRewrite.numInsertedObjs;
size_t toPrint = iPtr->ensembleRewrite.numRemovedObjs;
Tcl_Obj *const *origObjv = TclEnsembleGetRewriteValues(interp);
/*
* Only do rewrite the command if all the replaced objects are
* actually arguments (in objv) to this function. Otherwise it just
* gets too complicated and it's to just give a slightly
* confusing error message...
|
| ︙ | ︙ | |||
890 891 892 893 894 895 896 | } /* * Add a space if the word is not the last one (which has a * moderately complex condition here). */ | | | 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 |
}
/*
* Add a space if the word is not the last one (which has a
* moderately complex condition here).
*/
if (i+1<toPrint || objc!=0 || message!=NULL) {
Tcl_AppendStringsToObj(objPtr, " ", NULL);
}
}
}
/*
* Now add the arguments (other than those rewritten) that the caller took
|
| ︙ | ︙ | |||
940 941 942 943 944 945 946 |
}
/*
* Append a space character (" ") if there is more text to follow
* (either another element from objv, or the message string).
*/
| | | 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 |
}
/*
* Append a space character (" ") if there is more text to follow
* (either another element from objv, or the message string).
*/
if (i + 1 < objc || message!=NULL) {
Tcl_AppendStringsToObj(objPtr, " ", NULL);
}
}
/*
* Add any trailing message bits and set the resulting string as the
* interpreter result. Caller is responsible for reporting this as an
|
| ︙ | ︙ | |||
982 983 984 985 986 987 988 989 990 991 992 993 |
* Variables may be modified, or procedures may be called. It all depends
* on the arguments and their entries in argTable. See the user
* documentation for details.
*
*----------------------------------------------------------------------
*/
int
Tcl_ParseArgsObjv(
Tcl_Interp *interp, /* Place to store error message. */
const Tcl_ArgvInfo *argTable,
/* Array of option descriptions. */
| > | | | | | | 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 |
* Variables may be modified, or procedures may be called. It all depends
* on the arguments and their entries in argTable. See the user
* documentation for details.
*
*----------------------------------------------------------------------
*/
#undef Tcl_ParseArgsObjv
int
Tcl_ParseArgsObjv(
Tcl_Interp *interp, /* Place to store error message. */
const Tcl_ArgvInfo *argTable,
/* Array of option descriptions. */
size_t *objcPtr, /* Number of arguments in objv. Modified to
* hold # args left in objv at end. */
Tcl_Obj *const *objv, /* Array of arguments to be parsed. */
Tcl_Obj ***remObjv) /* Pointer to array of arguments that were not
* processed here. Should be NULL if no return
* of arguments is desired. */
{
Tcl_Obj **leftovers; /* Array to write back to remObjv on
* successful exit. Will include the name of
* the command. */
size_t nrem; /* Size of leftovers.*/
const Tcl_ArgvInfo *infoPtr;
/* Pointer to the current entry in the table
* of argument descriptions. */
const Tcl_ArgvInfo *matchPtr;
/* Descriptor that matches current argument */
Tcl_Obj *curArg; /* Current argument */
const char *str = NULL;
char c; /* Second character of current arg (used for
* quick check for matching; use 2nd char.
* because first char. will almost always be
* '-'). */
size_t srcIndex; /* Location from which to read next argument
* from objv. */
size_t dstIndex; /* Used to keep track of current arguments
* being processed, primarily for error
* reporting. */
size_t objc; /* # arguments in objv still to process. */
size_t length; /* Number of characters in current argument */
if (remObjv != NULL) {
/*
* Then we should copy the name of the command (0th argument). The
* upper bound on the number of elements is known, and (undocumented,
* but historically true) there should be a NULL argument after the
|
| ︙ | ︙ | |||
1052 1053 1054 1055 1056 1057 1058 |
if (length > 0) {
c = str[1];
} else {
c = 0;
}
/*
| | | 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 |
if (length > 0) {
c = str[1];
} else {
c = 0;
}
/*
* Loop through the argument descriptors searching for one with the
* matching key string. If found, leave a pointer to it in matchPtr.
*/
matchPtr = NULL;
infoPtr = argTable;
for (; infoPtr != NULL && infoPtr->type != TCL_ARGV_END ; infoPtr++) {
if (infoPtr->keyStr == NULL) {
|
| ︙ | ︙ | |||
1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 |
if (handlerProc(infoPtr->clientData, argObj, infoPtr->dstPtr)) {
srcIndex++;
objc--;
}
break;
}
case TCL_ARGV_GENFUNC: {
Tcl_ArgvGenFuncProc *handlerProc = (Tcl_ArgvGenFuncProc *)
infoPtr->srcPtr;
| > > > > > > > | | > | 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 |
if (handlerProc(infoPtr->clientData, argObj, infoPtr->dstPtr)) {
srcIndex++;
objc--;
}
break;
}
case TCL_ARGV_GENFUNC: {
int i = (int)objc;
if (objc > INT_MAX) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"too many (%" TCL_Z_MODIFIER "u) arguments for TCL_ARGV_GENFUNC", objc));
goto error;
}
Tcl_ArgvGenFuncProc *handlerProc = (Tcl_ArgvGenFuncProc *)
infoPtr->srcPtr;
i = handlerProc(infoPtr->clientData, interp, i,
&objv[srcIndex], infoPtr->dstPtr);
if (i < 0) {
goto error;
}
objc = i;
break;
}
case TCL_ARGV_HELP:
PrintUsage(interp, argTable);
goto error;
default:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
| ︙ | ︙ |
Changes to generic/tclInt.decls.
| ︙ | ︙ | |||
58 59 60 61 62 63 64 |
int TclDumpMemoryInfo(void *clientData, int flags)
}
declare 16 {
void TclExprFloatError(Tcl_Interp *interp, double value)
}
declare 22 {
int TclFindElement(Tcl_Interp *interp, const char *listStr,
| | | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 |
int TclDumpMemoryInfo(void *clientData, int flags)
}
declare 16 {
void TclExprFloatError(Tcl_Interp *interp, double value)
}
declare 22 {
int TclFindElement(Tcl_Interp *interp, const char *listStr,
size_t listLength, const char **elementPtr, const char **nextPtr,
size_t *sizePtr, int *bracePtr)
}
declare 23 {
Proc *TclFindProc(Interp *iPtr, const char *procName)
}
# Replaced with macro (see tclInt.h) in Tcl 8.5.0, restored in 8.5.10
declare 24 {
|
| ︙ | ︙ | |||
88 89 90 91 92 93 94 |
declare 38 {
int TclGetNamespaceForQualName(Tcl_Interp *interp, const char *qualName,
Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr,
Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr,
const char **simpleNamePtr)
}
declare 39 {
| | | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 |
declare 38 {
int TclGetNamespaceForQualName(Tcl_Interp *interp, const char *qualName,
Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr,
Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr,
const char **simpleNamePtr)
}
declare 39 {
Tcl_ObjCmdProc *TclGetObjInterpProc(void)
}
declare 40 {
int TclGetOpenMode(Tcl_Interp *interp, const char *str, int *seekFlagPtr)
}
declare 41 {
Tcl_Command TclGetOriginalCommand(Tcl_Command command)
}
|
| ︙ | ︙ | |||
260 261 262 263 264 265 266 |
const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
declare 142 {
int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr,
CompileHookProc *hookProc, void *clientData)
}
declare 143 {
| | | 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 |
const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
declare 142 {
int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr,
CompileHookProc *hookProc, void *clientData)
}
declare 143 {
size_t TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr,
LiteralEntry **litPtrPtr)
}
declare 144 {
void TclHideLiteral(Tcl_Interp *interp, struct CompileEnv *envPtr,
int index)
}
declare 145 {
|
| ︙ | ︙ | |||
335 336 337 338 339 340 341 |
declare 165 {
void TclpSetInitialEncodings(void)
}
# New function due to TIP #33
declare 166 {
int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
| | | 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 |
declare 165 {
void TclpSetInitialEncodings(void)
}
# New function due to TIP #33
declare 166 {
int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
size_t index, Tcl_Obj *valuePtr)
}
# variant of Tcl_UtfNCmp that takes n as bytes, not chars
declare 169 {
int TclpUtfNcmp2(const char *s1, const char *s2, size_t n)
}
declare 170 {
|
| ︙ | ︙ | |||
539 540 541 542 543 544 545 |
# TIP #285: Script cancellation support.
declare 250 {
void TclSetChildCancelFlags(Tcl_Interp *interp, int flags, int force)
}
# Allow extensions for optimization
declare 251 {
| | | 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 |
# TIP #285: Script cancellation support.
declare 250 {
void TclSetChildCancelFlags(Tcl_Interp *interp, int flags, int force)
}
# Allow extensions for optimization
declare 251 {
size_t TclRegisterLiteral(void *envPtr,
const char *bytes, size_t length, int flags)
}
# Exporting of the internal API to variables.
declare 252 {
Tcl_Obj *TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr,
|
| ︙ | ︙ | |||
579 580 581 582 583 584 585 586 587 588 589 590 591 592 |
# TIP 431: temporary directory creation function
declare 258 {
Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj)
}
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
# only available on the designated platform.
interface tclIntPlat
| > > > > > > > > > > > | 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 |
# TIP 431: temporary directory creation function
declare 258 {
Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj)
}
# TIP 625: for unit testing - create list objects with span
declare 260 {
Tcl_Obj *TclListTestObj(int length, int leadingSpace, int endSpace)
}
# TIP 625: for unit testing - check list invariants
declare 261 {
void TclListObjValidate(Tcl_Interp *interp, Tcl_Obj *listObj)
}
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
# only available on the designated platform.
interface tclIntPlat
|
| ︙ | ︙ |
Changes to generic/tclInt.h.
| ︙ | ︙ | |||
167 168 169 170 171 172 173 |
typedef struct Tcl_ResolvedVarInfo {
Tcl_ResolveRuntimeVarProc *fetchProc;
Tcl_ResolveVarDeleteProc *deleteProc;
} Tcl_ResolvedVarInfo;
typedef int (Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp,
| | | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 |
typedef struct Tcl_ResolvedVarInfo {
Tcl_ResolveRuntimeVarProc *fetchProc;
Tcl_ResolveVarDeleteProc *deleteProc;
} Tcl_ResolvedVarInfo;
typedef int (Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp,
const char *name, size_t length, Tcl_Namespace *context,
Tcl_ResolvedVarInfo **rPtr);
typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, const char *name,
Tcl_Namespace *context, int flags, Tcl_Var *rPtr);
typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, const char *name,
Tcl_Namespace *context, int flags, Tcl_Command *rPtr);
|
| ︙ | ︙ | |||
269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 |
* strings; values have type (Namespace *). */
#else
Tcl_HashTable *childTablePtr;
/* Contains any child namespaces. Indexed by
* strings; values have type (Namespace *). If
* NULL, there are no children. */
#endif
size_t nsId; /* Unique id for the namespace. */
Tcl_Interp *interp; /* The interpreter containing this
* namespace. */
int flags; /* OR-ed combination of the namespace status
* flags NS_DYING and NS_DEAD listed below. */
size_t activationCount; /* Number of "activations" or active call
* frames for this namespace that are on the
* Tcl call stack. The namespace won't be
| > > > > | 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 |
* strings; values have type (Namespace *). */
#else
Tcl_HashTable *childTablePtr;
/* Contains any child namespaces. Indexed by
* strings; values have type (Namespace *). If
* NULL, there are no children. */
#endif
#if TCL_MAJOR_VERSION > 8
size_t nsId; /* Unique id for the namespace. */
#else
unsigned long nsId;
#endif
Tcl_Interp *interp; /* The interpreter containing this
* namespace. */
int flags; /* OR-ed combination of the namespace status
* flags NS_DYING and NS_DEAD listed below. */
size_t activationCount; /* Number of "activations" or active call
* frames for this namespace that are on the
* Tcl call stack. The namespace won't be
|
| ︙ | ︙ | |||
308 309 310 311 312 313 314 |
size_t maxExportPatterns; /* Number of export patterns for which space
* is currently allocated. */
size_t cmdRefEpoch; /* Incremented if a newly added command
* shadows a command for which this namespace
* has already cached a Command* pointer; this
* causes all its cached Command* pointers to
* be invalidated. */
| | | 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 |
size_t maxExportPatterns; /* Number of export patterns for which space
* is currently allocated. */
size_t cmdRefEpoch; /* Incremented if a newly added command
* shadows a command for which this namespace
* has already cached a Command* pointer; this
* causes all its cached Command* pointers to
* be invalidated. */
size_t resolverEpoch; /* Incremented whenever (a) the name
* resolution rules change for this namespace
* or (b) a newly added command shadows a
* command that is compiled to bytecodes. This
* invalidates all byte codes compiled in the
* namespace, causing the code to be
* recompiled under the new rules.*/
Tcl_ResolveCmdProc *cmdResProc;
|
| ︙ | ︙ | |||
403 404 405 406 407 408 409 | * will be freed. * NS_SUPPRESS_COMPILATION - * Marks the commands in this namespace for not being compiled, * forcing them to be looked up every time. */ #define NS_DYING 0x01 | | | > | 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 | * will be freed. * NS_SUPPRESS_COMPILATION - * Marks the commands in this namespace for not being compiled, * forcing them to be looked up every time. */ #define NS_DYING 0x01 #define NS_DEAD 0x02 #define NS_TEARDOWN 0x04 #define NS_KILLED 0x04 /* Same as NS_TEARDOWN (Deprecated) */ #define NS_SUPPRESS_COMPILATION 0x08 /* * Flags passed to TclGetNamespaceForQualName: * * TCL_GLOBAL_ONLY - (see tcl.h) Look only in the global ns. * TCL_NAMESPACE_ONLY - (see tcl.h) Look only in the context ns. |
| ︙ | ︙ | |||
434 435 436 437 438 439 440 |
typedef struct EnsembleConfig {
Namespace *nsPtr; /* The namespace backing this ensemble up. */
Tcl_Command token; /* The token for the command that provides
* ensemble support for the namespace, or NULL
* if the command has been deleted (or never
* existed; the global namespace never has an
* ensemble command.) */
| | | 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 |
typedef struct EnsembleConfig {
Namespace *nsPtr; /* The namespace backing this ensemble up. */
Tcl_Command token; /* The token for the command that provides
* ensemble support for the namespace, or NULL
* if the command has been deleted (or never
* existed; the global namespace never has an
* ensemble command.) */
size_t epoch; /* The epoch at which this ensemble's table of
* exported commands is valid. */
char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all
* consistent points, this will have the same
* number of entries as there are entries in
* the subcommandTable hash. */
Tcl_HashTable subcommandTable;
/* Hash table of ensemble subcommand names,
|
| ︙ | ︙ | |||
491 492 493 494 495 496 497 |
* results passed directly back to the caller
* (including the error code) unless the code
* is TCL_CONTINUE in which case the
* subcommand will be reparsed by the ensemble
* core, presumably because the ensemble
* itself has been updated. */
Tcl_Obj *parameterList; /* List of ensemble parameter names. */
| | | 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 |
* results passed directly back to the caller
* (including the error code) unless the code
* is TCL_CONTINUE in which case the
* subcommand will be reparsed by the ensemble
* core, presumably because the ensemble
* itself has been updated. */
Tcl_Obj *parameterList; /* List of ensemble parameter names. */
size_t numParameters; /* Cached number of parameters. This is either
* 0 (if the parameterList field is NULL) or
* the length of the list in the parameterList
* field. */
} EnsembleConfig;
/*
* Various bits for the EnsembleConfig.flags field.
|
| ︙ | ︙ | |||
547 548 549 550 551 552 553 |
void *clientData; /* Argument to pass to proc. */
int flags; /* What events the trace procedure is
* interested in: OR-ed combination of
* TCL_TRACE_RENAME, TCL_TRACE_DELETE. */
struct CommandTrace *nextPtr;
/* Next in list of traces associated with a
* particular command. */
| | | 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 |
void *clientData; /* Argument to pass to proc. */
int flags; /* What events the trace procedure is
* interested in: OR-ed combination of
* TCL_TRACE_RENAME, TCL_TRACE_DELETE. */
struct CommandTrace *nextPtr;
/* Next in list of traces associated with a
* particular command. */
size_t refCount; /* Used to ensure this structure is not
* deleted too early. Keeps track of how many
* pieces of code have a pointer to this
* structure. */
} CommandTrace;
/*
* When a command trace is active (i.e. its associated procedure is executing)
|
| ︙ | ︙ | |||
892 893 894 895 896 897 898 | /* *---------------------------------------------------------------- * Data structures related to procedures. These are used primarily in * tclProc.c, tclCompile.c, and tclExecute.c. *---------------------------------------------------------------- */ | > > | | 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 | /* *---------------------------------------------------------------- * Data structures related to procedures. These are used primarily in * tclProc.c, tclCompile.c, and tclExecute.c. *---------------------------------------------------------------- */ #if defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) # define TCLFLEXARRAY #elif defined(__GNUC__) && (__GNUC__ > 2) # define TCLFLEXARRAY 0 #else # define TCLFLEXARRAY 1 #endif /* * Forward declaration to prevent an error when the forward reference to |
| ︙ | ︙ | |||
925 926 927 928 929 930 931 |
typedef struct CompiledLocal {
struct CompiledLocal *nextPtr;
/* Next compiler-recognized local variable for
* this procedure, or NULL if this is the last
* local. */
size_t nameLength; /* The number of bytes in local variable's name.
* Among others used to speed up var lookups. */
| | > | < < | > > > > > > | 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 |
typedef struct CompiledLocal {
struct CompiledLocal *nextPtr;
/* Next compiler-recognized local variable for
* this procedure, or NULL if this is the last
* local. */
size_t nameLength; /* The number of bytes in local variable's name.
* Among others used to speed up var lookups. */
size_t frameIndex; /* Index in the array of compiler-assigned
* variables in the procedure call frame. */
#if TCL_MAJOR_VERSION < 9
int flags;
#endif
Tcl_Obj *defValuePtr; /* Pointer to the default value of an
* argument, if any. NULL if not an argument
* or, if an argument, no default value. */
Tcl_ResolvedVarInfo *resolveInfo;
/* Customized variable resolution info
* supplied by the Tcl_ResolveCompiledVarProc
* associated with a namespace. Each variable
* is marked by a unique tag during
* compilation, and that same tag is used to
* find the variable at runtime. */
#if TCL_MAJOR_VERSION > 8
int flags; /* Flag bits for the local variable. Same as
* the flags for the Var structure above,
* although only VAR_ARGUMENT, VAR_TEMPORARY,
* and VAR_RESOLVED make sense. */
#endif
char name[TCLFLEXARRAY]; /* Name of the local variable starts here. If
* the name is NULL, this will just be '\0'.
* The actual size of this field will be large
* enough to hold the name. MUST BE THE LAST
* FIELD IN THE STRUCTURE! */
} CompiledLocal;
|
| ︙ | ︙ | |||
968 969 970 971 972 973 974 |
* becomes zero. */
struct Command *cmdPtr; /* Points to the Command structure for this
* procedure. This is used to get the
* namespace in which to execute the
* procedure. */
Tcl_Obj *bodyPtr; /* Points to the ByteCode object for
* procedure's body command. */
| | | | 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 |
* becomes zero. */
struct Command *cmdPtr; /* Points to the Command structure for this
* procedure. This is used to get the
* namespace in which to execute the
* procedure. */
Tcl_Obj *bodyPtr; /* Points to the ByteCode object for
* procedure's body command. */
size_t numArgs; /* Number of formal parameters. */
size_t numCompiledLocals; /* Count of local variables recognized by the
* compiler including arguments and
* temporaries. */
CompiledLocal *firstLocalPtr;
/* Pointer to first of the procedure's
* compiler-allocated local variables, or NULL
* if none. The first numArgs entries in this
* list describe the procedure's formal
|
| ︙ | ︙ | |||
1075 1076 1077 1078 1079 1080 1081 |
/*
* Will be grown to contain: pointers to the varnames (allocated at the end),
* plus the init values for each variable (suitable to be memcopied on init)
*/
typedef struct LocalCache {
size_t refCount;
| | | | | | | 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 |
/*
* Will be grown to contain: pointers to the varnames (allocated at the end),
* plus the init values for each variable (suitable to be memcopied on init)
*/
typedef struct LocalCache {
size_t refCount;
size_t numVars;
Tcl_Obj *varName0;
} LocalCache;
#define localName(framePtr, i) \
((&((framePtr)->localCachePtr->varName0))[(i)])
MODULE_SCOPE void TclFreeLocalCache(Tcl_Interp *interp,
LocalCache *localCachePtr);
typedef struct CallFrame {
Namespace *nsPtr; /* Points to the namespace used to resolve
* commands and global variables. */
int isProcCallFrame; /* If 0, the frame was pushed to execute a
* namespace command and var references are
* treated as references to namespace vars;
* varTablePtr and compiledLocals are ignored.
* If FRAME_IS_PROC is set, the frame was
* pushed to execute a Tcl procedure and may
* have local vars. */
size_t objc; /* This and objv below describe the arguments
* for this procedure call. */
Tcl_Obj *const *objv; /* Array of argument objects. */
struct CallFrame *callerPtr;
/* Value of interp->framePtr when this
* procedure was invoked (i.e. next higher in
* stack of all active procedures). */
struct CallFrame *callerVarPtr;
/* Value of interp->varFramePtr when this
* procedure was invoked (i.e. determines
* variable scoping within caller). Same as
* callerPtr unless an "uplevel" command or
* something equivalent was active in the
* caller). */
size_t level; /* Level of this procedure, for "uplevel"
* purposes (i.e. corresponds to nesting of
* callerVarPtr's, not callerPtr's). 1 for
* outermost procedure, 0 for top-level. */
Proc *procPtr; /* Points to the structure defining the called
* procedure. Used to get information such as
* the number of compiled local variables
* (local variables assigned entries ["slots"]
* in the compiledLocals array below). */
TclVarHashTable *varTablePtr;
/* Hash table containing local variables not
* recognized by the compiler, or created at
* execution time through, e.g., upvar.
* Initially NULL and created if needed. */
size_t numCompiledLocals; /* Count of local variables recognized
* by the compiler including arguments. */
Var *compiledLocals; /* Points to the array of local variables
* recognized by the compiler. The compiler
* emits code that refers to these variables
* using an index into this array. */
void *clientData; /* Pointer to some context that is used by
* object systems. The meaning of the contents
* of this field is defined by the code that
|
| ︙ | ︙ | |||
1185 1186 1187 1188 1189 1190 1191 |
* General data. Always available.
*/
int type; /* Values see below. */
int level; /* Number of frames in stack, prevent O(n)
* scan of list. */
int *line; /* Lines the words of the command start on. */
| | | 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 |
* General data. Always available.
*/
int type; /* Values see below. */
int level; /* Number of frames in stack, prevent O(n)
* scan of list. */
int *line; /* Lines the words of the command start on. */
size_t nline;
CallFrame *framePtr; /* Procedure activation record, may be
* NULL. */
struct CmdFrame *nextPtr; /* Link to calling frame. */
/*
* Data needed for Eval vs TEBC
*
* EXECUTION CONTEXTS and usage of CmdFrame
|
| ︙ | ︙ | |||
1239 1240 1241 1242 1243 1244 1245 |
* ben pushed on the lineLABCPtr stack by
* TclArgumentBCEnter(). These will be removed
* by TclArgumentBCRelease. */
} CmdFrame;
typedef struct CFWord {
CmdFrame *framePtr; /* CmdFrame to access. */
| | | | 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 |
* ben pushed on the lineLABCPtr stack by
* TclArgumentBCEnter(). These will be removed
* by TclArgumentBCRelease. */
} CmdFrame;
typedef struct CFWord {
CmdFrame *framePtr; /* CmdFrame to access. */
size_t word; /* Index of the word in the command. */
size_t refCount; /* Number of times the word is on the
* stack. */
} CFWord;
typedef struct CFWordBC {
CmdFrame *framePtr; /* CmdFrame to access. */
size_t pc; /* Instruction pointer of a command in
* ExtCmdLoc.loc[.] */
size_t word; /* Index of word in
* ExtCmdLoc.loc[cmd]->line[.] */
struct CFWordBC *prevPtr; /* Previous entry in stack for same Tcl_Obj. */
struct CFWordBC *nextPtr; /* Next entry for same command call. See
* CmdFrame litarg field for the list start. */
Tcl_Obj *obj; /* Back reference to hashtable key */
} CFWordBC;
|
| ︙ | ︙ | |||
1277 1278 1279 1280 1281 1282 1283 |
* released by the function TclFreeObj(), in the file "tclObj.c", and also by
* the function TclThreadFinalizeObjects(), in the same file.
*/
#define CLL_END (-1)
typedef struct ContLineLoc {
| | | 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 |
* released by the function TclFreeObj(), in the file "tclObj.c", and also by
* the function TclThreadFinalizeObjects(), in the same file.
*/
#define CLL_END (-1)
typedef struct ContLineLoc {
size_t num; /* Number of entries in loc, not counting the
* final -1 marker entry. */
int loc[TCLFLEXARRAY];/* Table of locations, as character offsets.
* The table is allocated as part of the
* structure, extending behind the nominal end
* of the structure. An entry containing the
* value -1 is put after the last location, as
* end-marker/sentinel. */
|
| ︙ | ︙ | |||
1526 1527 1528 1529 1530 1531 1532 |
typedef struct LiteralTable {
LiteralEntry **buckets; /* Pointer to bucket array. Each element
* points to first entry in bucket's hash
* chain, or NULL. */
LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
/* Bucket array used for small tables to avoid
* mallocs and frees. */
| | | | | | 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 |
typedef struct LiteralTable {
LiteralEntry **buckets; /* Pointer to bucket array. Each element
* points to first entry in bucket's hash
* chain, or NULL. */
LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
/* Bucket array used for small tables to avoid
* mallocs and frees. */
TCL_HASH_TYPE numBuckets; /* Total number of buckets allocated at
* **buckets. */
TCL_HASH_TYPE numEntries; /* Total number of entries present in
* table. */
TCL_HASH_TYPE rebuildSize; /* Enlarge table when numEntries gets to be
* this large. */
TCL_HASH_TYPE mask; /* Mask value used in hashing function. */
} LiteralTable;
/*
* The following structure defines for each Tcl interpreter various
* statistics-related information about the bytecode compiler and
* interpreter's operation in that interpreter.
*/
|
| ︙ | ︙ | |||
1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 |
Tcl_HashTable *hiddenCmdTablePtr;
/* Hash table used by tclBasic.c to keep track
* of hidden commands on a per-interp
* basis. */
void *interpInfo; /* Information used by tclInterp.c to keep
* track of parent/child interps on a
* per-interp basis. */
void (*optimizer)(void *envPtr);
/*
* Information related to procedures and variables. See tclProc.c and
* tclVar.c for usage.
*/
size_t numLevels; /* Keeps track of how many nested calls to
* Tcl_Eval are in progress for this
| > > > > > > > > > > > | 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 |
Tcl_HashTable *hiddenCmdTablePtr;
/* Hash table used by tclBasic.c to keep track
* of hidden commands on a per-interp
* basis. */
void *interpInfo; /* Information used by tclInterp.c to keep
* track of parent/child interps on a
* per-interp basis. */
#if TCL_MAJOR_VERSION > 8
void (*optimizer)(void *envPtr);
#else
union {
void (*optimizer)(void *envPtr);
Tcl_HashTable unused2; /* No longer used (was mathFuncTable). The
* unused space in interp was repurposed for
* pluggable bytecode optimizers. The core
* contains one optimizer, which can be
* selectively overridden by extensions. */
} extra;
#endif
/*
* Information related to procedures and variables. See tclProc.c and
* tclVar.c for usage.
*/
size_t numLevels; /* Keeps track of how many nested calls to
* Tcl_Eval are in progress for this
|
| ︙ | ︙ | |||
1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 |
* or NULL if no active traces. */
int returnCode; /* [return -code] parameter. */
CallFrame *rootFramePtr; /* Global frame pointer for this
* interpreter. */
Namespace *lookupNsPtr; /* Namespace to use ONLY on the next
* TCL_EVAL_INVOKE call to Tcl_EvalObjv. */
/*
* Information about packages. Used only in tclPkg.c.
*/
Tcl_HashTable packageTable; /* Describes all of the packages loaded in or
* available to this interpreter. Keys are
* package names, values are (Package *)
| > > > > > > | 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 |
* or NULL if no active traces. */
int returnCode; /* [return -code] parameter. */
CallFrame *rootFramePtr; /* Global frame pointer for this
* interpreter. */
Namespace *lookupNsPtr; /* Namespace to use ONLY on the next
* TCL_EVAL_INVOKE call to Tcl_EvalObjv. */
#if TCL_MAJOR_VERSION < 9
char *appendResultDontUse;
int appendAvlDontUse;
int appendUsedDontUse;
#endif
/*
* Information about packages. Used only in tclPkg.c.
*/
Tcl_HashTable packageTable; /* Describes all of the packages loaded in or
* available to this interpreter. Keys are
* package names, values are (Package *)
|
| ︙ | ︙ | |||
1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 |
size_t cmdCount; /* Total number of times a command procedure
* has been called for this interpreter. */
int evalFlags; /* Flags to control next call to Tcl_Eval.
* Normally zero, but may be set before
* calling Tcl_Eval. See below for valid
* values. */
LiteralTable literalTable; /* Contains LiteralEntry's describing all Tcl
* objects holding literals of scripts
* compiled by the interpreter. Indexed by the
* string representations of literals. Used to
* avoid creating duplicate objects. */
| > > > | | 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 |
size_t cmdCount; /* Total number of times a command procedure
* has been called for this interpreter. */
int evalFlags; /* Flags to control next call to Tcl_Eval.
* Normally zero, but may be set before
* calling Tcl_Eval. See below for valid
* values. */
#if TCL_MAJOR_VERSION < 9
int unused1; /* No longer used (was termOffset) */
#endif
LiteralTable literalTable; /* Contains LiteralEntry's describing all Tcl
* objects holding literals of scripts
* compiled by the interpreter. Indexed by the
* string representations of literals. Used to
* avoid creating duplicate objects. */
size_t compileEpoch; /* Holds the current "compilation epoch" for
* this interpreter. This is incremented to
* invalidate existing ByteCodes when, e.g., a
* command with a compile procedure is
* redefined. */
Proc *compiledProcPtr; /* If a procedure is being compiled, a pointer
* to its Proc structure; otherwise, this is
* NULL. Set by ObjInterpProc in tclProc.c and
|
| ︙ | ︙ | |||
1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 |
struct ExecEnv *execEnvPtr; /* Execution environment for Tcl bytecode
* execution. Contains a pointer to the Tcl
* evaluation stack. */
Tcl_Obj *emptyObjPtr; /* Points to an object holding an empty
* string. Returned by Tcl_ObjSetVar2 when
* variable traces change a variable in a
* gross way. */
Tcl_Obj *objResultPtr; /* If the last command returned an object
* result, this points to it. Should not be
* accessed directly; see comment above. */
Tcl_ThreadId threadId; /* ID of thread that owns the interpreter. */
ActiveCommandTrace *activeCmdTracePtr;
/* First in list of active command traces for
* interp, or NULL if no active traces. */
ActiveInterpTrace *activeInterpTracePtr;
/* First in list of active traces for interp,
* or NULL if no active traces. */
| > > > | | 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 |
struct ExecEnv *execEnvPtr; /* Execution environment for Tcl bytecode
* execution. Contains a pointer to the Tcl
* evaluation stack. */
Tcl_Obj *emptyObjPtr; /* Points to an object holding an empty
* string. Returned by Tcl_ObjSetVar2 when
* variable traces change a variable in a
* gross way. */
#if TCL_MAJOR_VERSION < 9
char resultSpaceDontUse[TCL_DSTRING_STATIC_SIZE+1];
#endif
Tcl_Obj *objResultPtr; /* If the last command returned an object
* result, this points to it. Should not be
* accessed directly; see comment above. */
Tcl_ThreadId threadId; /* ID of thread that owns the interpreter. */
ActiveCommandTrace *activeCmdTracePtr;
/* First in list of active command traces for
* interp, or NULL if no active traces. */
ActiveInterpTrace *activeInterpTracePtr;
/* First in list of active traces for interp,
* or NULL if no active traces. */
size_t tracesForbiddingInline; /* Count of traces (in the list headed by
* tracePtr) that forbid inline bytecode
* compilation. */
/*
* Fields used to manage extensible return options (TIP 90).
*/
|
| ︙ | ︙ | |||
2290 2291 2292 2293 2294 2295 2296 | #if defined(__APPLE__) #define TCL_ALLOCALIGN 16 #else #define TCL_ALLOCALIGN (2*sizeof(void *)) #endif /* | | | | | > | | > > > > > > > > > > | > | 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 |
#if defined(__APPLE__)
#define TCL_ALLOCALIGN 16
#else
#define TCL_ALLOCALIGN (2*sizeof(void *))
#endif
/*
* TCL_ALIGN is used to determine the offset needed to safely allocate any
* data structure in memory. Given a starting offset or size, it "rounds up"
* or "aligns" the offset to the next aligned (typically 8-byte) boundary so
* that any data structure can be placed at the resulting offset without fear
* of an alignment error. Note this is clamped to a minimum of 8 for API
* compatibility.
*
* WARNING!! DO NOT USE THIS MACRO TO ALIGN POINTERS: it will produce the
* wrong result on platforms that allocate addresses that are divisible by a
* non-trivial factor of this alignment. Only use it for offsets or sizes.
*
* This macro is only used by tclCompile.c in the core (Bug 926445). It
* however not be made file static, as extensions that touch bytecodes
* (notably tbcload) require it.
*/
struct TclMaxAlignment {
char unalign[8];
union {
long long maxAlignLongLong;
double maxAlignDouble;
void *maxAlignPointer;
} aligned;
};
#define TCL_ALIGN_BYTES \
offsetof(struct TclMaxAlignment, aligned)
#define TCL_ALIGN(x) \
(((x) + (TCL_ALIGN_BYTES - 1)) & ~(TCL_ALIGN_BYTES - 1))
/*
* A common panic alert when memory allocation fails.
*/
#define TclOOM(ptr, size) \
((size) && ((ptr)||(Tcl_Panic("unable to alloc %" TCL_Z_MODIFIER "u bytes", (size_t)(size)),1)))
|
| ︙ | ︙ | |||
2357 2358 2359 2360 2361 2362 2363 | */ #define TCL_INVOKE_HIDDEN (1<<0) #define TCL_INVOKE_NO_UNKNOWN (1<<1) #define TCL_INVOKE_NO_TRACEBACK (1<<2) /* | | | < < < > | | > > > > > | > | | > | > | | > > > > | > > > > > | > > > > > > > > > > | > > > > > > > > > > > > > > > | > | > | | > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > | > | > | > > > | > > > | > > | > > > > > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > | > > > > > > | | | | | | | 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 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 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 |
*/
#define TCL_INVOKE_HIDDEN (1<<0)
#define TCL_INVOKE_NO_UNKNOWN (1<<1)
#define TCL_INVOKE_NO_TRACEBACK (1<<2)
/*
* ListSizeT is the type for holding list element counts. It's defined
* simplify sharing source between Tcl8 and Tcl9.
*/
#if TCL_MAJOR_VERSION > 8
typedef ssize_t ListSizeT;
/*
* SSIZE_MAX, NOT SIZE_MAX as negative differences need to be expressed
* between values of the ListSizeT type so limit the range to signed
*/
#define ListSizeT_MAX ((ListSizeT)PTRDIFF_MAX)
#else
typedef int ListSizeT;
#define ListSizeT_MAX INT_MAX
#endif
/*
* ListStore --
*
* A Tcl list's internal representation is defined through three structures.
*
* A ListStore struct is a structure that includes a variable size array that
* serves as storage for a Tcl list. A contiguous sequence of slots in the
* array, the "in-use" area, holds valid pointers to Tcl_Obj values that
* belong to one or more Tcl lists. The unused slots before and after these
* are free slots that may be used to prepend and append without having to
* reallocate the struct. The ListStore may be shared amongst multiple lists
* and reference counted.
*
* A ListSpan struct defines a sequence of slots within a ListStore. This sequence
* always lies within the "in-use" area of the ListStore. Like ListStore, the
* structure may be shared among multiple lists and is reference counted.
*
* A ListRep struct holds the internal representation of a Tcl list as stored
* in a Tcl_Obj. It is composed of a ListStore and a ListSpan that together
* define the content of the list. The ListSpan specifies the range of slots
* within the ListStore that hold elements for this list. The ListSpan is
* optional in which case the list includes all the "in-use" slots of the
* ListStore.
*
*/
typedef struct ListStore {
ListSizeT firstUsed; /* Index of first slot in use within slots[] */
ListSizeT numUsed; /* Number of slots in use (starting firstUsed) */
ListSizeT numAllocated; /* Total number of slots[] array slots. */
size_t refCount; /* Number of references to this instance */
int flags; /* LISTSTORE_* flags */
Tcl_Obj *slots[TCLFLEXARRAY]; /* Variable size array. Grown as needed */
} ListStore;
#define LISTSTORE_CANONICAL 0x1 /* All Tcl_Obj's referencing this
store have their string representation
derived from the list representation */
/* Max number of elements that can be contained in a list */
#define LIST_MAX \
((ListSizeT_MAX - offsetof(ListStore, slots)) \
/ sizeof(Tcl_Obj *))
/* Memory size needed for a ListStore to hold numSlots_ elements */
#define LIST_SIZE(numSlots_) \
(offsetof(ListStore, slots) + ((numSlots_) * sizeof(Tcl_Obj *)))
/*
* ListSpan --
* See comments above for ListStore
*/
typedef struct ListSpan {
ListSizeT spanStart; /* Starting index of the span */
ListSizeT spanLength; /* Number of elements in the span */
size_t refCount; /* Count of references to this span record */
} ListSpan;
#ifndef LIST_SPAN_THRESHOLD /* May be set on build line */
#define LIST_SPAN_THRESHOLD 101
#endif
/*
* ListRep --
* See comments above for ListStore
*/
typedef struct ListRep {
ListStore *storePtr;/* element array shared amongst different lists */
ListSpan *spanPtr; /* If not NULL, the span holds the range of slots
within *storePtr that contain this list elements. */
} ListRep;
/*
* Macros used to get access list internal representations.
*
* Naming conventions:
* ListRep* - expect a pointer to a valid ListRep
* ListObj* - expect a pointer to a Tcl_Obj whose internal type is known to
* be a list (tclListType). Will crash otherwise.
* TclListObj* - expect a pointer to a Tcl_Obj whose internal type may or may not
* be tclListType. These will convert as needed and return error if
* conversion not possible.
*/
/* Returns the starting slot for this listRep in the contained ListStore */
#define ListRepStart(listRepPtr_) \
((listRepPtr_)->spanPtr ? (listRepPtr_)->spanPtr->spanStart \
: (listRepPtr_)->storePtr->firstUsed)
/* Returns the number of elements in this listRep */
#define ListRepLength(listRepPtr_) \
((listRepPtr_)->spanPtr ? (listRepPtr_)->spanPtr->spanLength \
: (listRepPtr_)->storePtr->numUsed)
/* Returns a pointer to the first slot containing this ListRep elements */
#define ListRepElementsBase(listRepPtr_) \
(&(listRepPtr_)->storePtr->slots[ListRepStart(listRepPtr_)])
/* Stores the number of elements and base address of the element array */
#define ListRepElements(listRepPtr_, objc_, objv_) \
(((objv_) = ListRepElementsBase(listRepPtr_)), \
((objc_) = ListRepLength(listRepPtr_)))
/* Returns 1/0 whether the ListRep's ListStore is shared. */
#define ListRepIsShared(listRepPtr_) ((listRepPtr_)->storePtr->refCount > 1)
/* Returns a pointer to the ListStore component */
#define ListObjStorePtr(listObj_) \
((ListStore *)((listObj_)->internalRep.twoPtrValue.ptr1))
/* Returns a pointer to the ListSpan component */
#define ListObjSpanPtr(listObj_) \
((ListSpan *)((listObj_)->internalRep.twoPtrValue.ptr2))
/* Returns the ListRep internal representaton in a Tcl_Obj */
#define ListObjGetRep(listObj_, listRepPtr_) \
do { \
(listRepPtr_)->storePtr = ListObjStorePtr(listObj_); \
(listRepPtr_)->spanPtr = ListObjSpanPtr(listObj_); \
} while (0)
/* Returns the length of the list */
#define ListObjLength(listObj_, len_) \
((len_) = ListObjSpanPtr(listObj_) ? ListObjSpanPtr(listObj_)->spanLength \
: ListObjStorePtr(listObj_)->numUsed)
/* Returns the starting slot index of this list's elements in the ListStore */
#define ListObjStart(listObj_) \
(ListObjSpanPtr(listObj_) ? ListObjSpanPtr(listObj_)->spanStart \
: ListObjStorePtr(listObj_)->firstUsed)
/* Stores the element count and base address of this list's elements */
#define ListObjGetElements(listObj_, objc_, objv_) \
(((objv_) = &ListObjStorePtr(listObj_)->slots[ListObjStart(listObj_)]), \
(ListObjLength(listObj_, (objc_))))
/*
* Returns 1/0 whether the internal representation (not the Tcl_Obj itself)
* is shared. Note by intent this only checks for sharing of ListStore,
* not spans.
*/
#define ListObjRepIsShared(listObj_) (ListObjStorePtr(listObj_)->refCount > 1)
/*
* Certain commands like concat are optimized if an existing string
* representation of a list object is known to be in canonical format (i.e.
* generated from the list representation). There are three conditions when
* this will be the case:
* (1) No string representation exists which means it will obviously have
* to be generated from the list representation when needed
* (2) The ListStore flags is marked canonical. This is done at the time
* the string representation is generated from the list IF the list
* representation does not have a span (see comments in UpdateStringOfList).
* (3) The list representation does not have a span component. This is
* because list Tcl_Obj's with spans are always created from existing lists
* and never from strings (see SetListFromAny) and thus their string
* representation will always be canonical.
*/
#define ListObjIsCanonical(listObj_) \
(((listObj_)->bytes == NULL) \
|| (ListObjStorePtr(listObj_)->flags & LISTSTORE_CANONICAL) \
|| ListObjSpanPtr(listObj_) != NULL)
/*
* Converts the Tcl_Obj to a list if it isn't one and stores the element
* count and base address of this list's elements in objcPtr_ and objvPtr_.
* Return TCL_OK on success or TCL_ERROR if the Tcl_Obj cannot be
* converted to a list.
*/
#define TclListObjGetElementsM(interp_, listObj_, objcPtr_, objvPtr_) \
(((listObj_)->typePtr == &tclListType) \
? ((ListObjGetElements((listObj_), *(objcPtr_), *(objvPtr_))), \
TCL_OK) \
: Tcl_ListObjGetElements( \
(interp_), (listObj_), (objcPtr_), (objvPtr_)))
/*
* Converts the Tcl_Obj to a list if it isn't one and stores the element
* count in lenPtr_. Returns TCL_OK on success or TCL_ERROR if the
* Tcl_Obj cannot be converted to a list.
*/
#define TclListObjLengthM(interp_, listObj_, lenPtr_) \
(((listObj_)->typePtr == &tclListType) \
? ((ListObjLength((listObj_), *(lenPtr_))), TCL_OK) \
: Tcl_ListObjLength((interp_), (listObj_), (lenPtr_)))
#define TclListObjIsCanonical(listObj_) \
(((listObj_)->typePtr == &tclListType) ? ListObjIsCanonical((listObj_)) : 0)
/*
* Modes for collecting (or not) in the implementations of TclNRForeachCmd,
* TclNRLmapCmd and their compilations.
*/
#define TCL_EACH_KEEP_NONE 0 /* Discard iteration result like [foreach] */
|
| ︙ | ︙ | |||
2571 2572 2573 2574 2575 2576 2577 | */ typedef int (TclStatProc_)(const char *path, struct stat *buf); typedef int (TclAccessProc_)(const char *path, int mode); typedef Tcl_Channel (TclOpenFileChannelProc_)(Tcl_Interp *interp, const char *fileName, const char *modeString, int permissions); | < < < < < < < < < | | | | 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 |
*/
typedef int (TclStatProc_)(const char *path, struct stat *buf);
typedef int (TclAccessProc_)(const char *path, int mode);
typedef Tcl_Channel (TclOpenFileChannelProc_)(Tcl_Interp *interp,
const char *fileName, const char *modeString, int permissions);
/*
*----------------------------------------------------------------
* Data structures for process-global values.
*----------------------------------------------------------------
*/
typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, TCL_HASH_TYPE *lengthPtr,
Tcl_Encoding *encodingPtr);
/*
* A ProcessGlobalValue struct exists for each internal value in Tcl that is
* to be shared among several threads. Each thread sees a (Tcl_Obj) copy of
* the value, and the gobal value is kept as a counted string, with epoch and
* mutex control. Each ProcessGlobalValue struct should be a static variable in
* some file.
*/
typedef struct ProcessGlobalValue {
size_t epoch; /* Epoch counter to detect changes in the
* global value. */
TCL_HASH_TYPE numBytes; /* Length of the global string. */
char *value; /* The global string value. */
Tcl_Encoding encoding; /* system encoding when global string was
* initialized. */
TclInitProcessGlobalValueProc *proc;
/* A procedure to initialize the global string
* copy when a "get" request comes in before
* any "set" request has been received. */
|
| ︙ | ︙ | |||
2780 2781 2782 2783 2784 2785 2786 |
*/
typedef struct ForIterData {
Tcl_Obj *cond; /* Loop condition expression. */
Tcl_Obj *body; /* Loop body. */
Tcl_Obj *next; /* Loop step script, NULL for 'while'. */
const char *msg; /* Error message part. */
| | | 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 |
*/
typedef struct ForIterData {
Tcl_Obj *cond; /* Loop condition expression. */
Tcl_Obj *body; /* Loop body. */
Tcl_Obj *next; /* Loop step script, NULL for 'while'. */
const char *msg; /* Error message part. */
size_t word; /* Index of the body script in the command */
} ForIterData;
/* TIP #357 - Structure doing the bookkeeping of handles for Tcl_LoadFile
* and Tcl_FindSymbol. This structure corresponds to an opaque
* typedef in tcl.h */
typedef void* TclFindSymbolProc(Tcl_Interp* interp, Tcl_LoadHandle loadHandle,
|
| ︙ | ︙ | |||
2828 2829 2830 2831 2832 2833 2834 | *---------------------------------------------------------------- */ MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr, const unsigned char *bytes, ssize_t len); MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); | | | | | | | > > | | 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 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 | *---------------------------------------------------------------- */ MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr, const unsigned char *bytes, ssize_t len); MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); MODULE_SCOPE void TclAdvanceContinuations(size_t *line, int **next, int loc); MODULE_SCOPE void TclAdvanceLines(size_t *line, const char *start, const char *end); MODULE_SCOPE void TclArgumentEnter(Tcl_Interp *interp, Tcl_Obj *objv[], int objc, CmdFrame *cf); MODULE_SCOPE void TclArgumentRelease(Tcl_Interp *interp, Tcl_Obj *objv[], int objc); MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp, Tcl_Obj *objv[], int objc, void *codePtr, CmdFrame *cfPtr, int cmd, size_t pc); MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp, CmdFrame *cfPtr); MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, CmdFrame **cfPtrPtr, int *wordPtr); MODULE_SCOPE int TclAsyncNotifier(int sigNumber, Tcl_ThreadId threadId, void *clientData, int *flagPtr, int value); MODULE_SCOPE void TclAsyncMarkFromNotifier(void); MODULE_SCOPE double TclBignumToDouble(const void *bignum); MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, size_t strLen, const unsigned char *pattern, size_t ptnLen, int flags); MODULE_SCOPE double TclCeil(const void *a); MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan); MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan); MODULE_SCOPE int TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *name, int index); MODULE_SCOPE int TclCheckEmptyString(Tcl_Obj *objPtr); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, size_t num, int *loc); MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, int start, int *clNext); MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr); MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr, Tcl_Obj *originObjPtr); MODULE_SCOPE size_t TclConvertElement(const char *src, ssize_t length, char *dst, int flags); MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs(Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *nsPtr, Tcl_ObjCmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp, const char *name, Tcl_Namespace *nameNamespacePtr, Tcl_Namespace *ensembleNamespacePtr, int flags); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); MODULE_SCOPE void TclDeleteNamespaceChildren(Namespace *nsPtr); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, const char *dict, size_t dictLength, const char **elementPtr, const char **nextPtr, size_t *sizePtr, int *literalPtr); /* TIP #280 - Modified token based evaluation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, ssize_t numBytes, int flags, ssize_t line, int *clNextOuter, const char *outerScript); MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileDeleteCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileLinkCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileMakeDirsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileReadLinkCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileTempDirCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileHomeCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileTildeExpandCmd; MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc, void *clientData); MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc, void *clientData); MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr, Tcl_Obj *objPtr); MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, Tcl_DString *toAppendPtr); MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp, Tcl_Obj *const *objv, size_t objc, size_t *objcPtr); MODULE_SCOPE Tcl_Obj *const *TclEnsembleGetRewriteValues(Tcl_Interp *interp); MODULE_SCOPE Tcl_Namespace *TclEnsureNamespace(Tcl_Interp *interp, Tcl_Namespace *namespacePtr); MODULE_SCOPE void TclFinalizeAllocSubsystem(void); MODULE_SCOPE void TclFinalizeAsync(void); MODULE_SCOPE void TclFinalizeDoubleConversion(void); MODULE_SCOPE void TclFinalizeEncodingSubsystem(void); |
| ︙ | ︙ | |||
2940 2941 2942 2943 2944 2945 2946 | MODULE_SCOPE double TclFloor(const void *a); MODULE_SCOPE void TclFormatNaN(double value, char *buffer); MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, const char *attributeName, int *indexPtr); MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs(Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *nsPtr, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, | < | | 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 | MODULE_SCOPE double TclFloor(const void *a); MODULE_SCOPE void TclFormatNaN(double value, char *buffer); MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, const char *attributeName, int *indexPtr); MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs(Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *nsPtr, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, void *clientData, Tcl_CmdDeleteProc *deleteProc); MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *encodingName); MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle); MODULE_SCOPE int * TclGetAsyncReadyPtr(void); MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler(Tcl_Interp *interp); MODULE_SCOPE int TclGetChannelFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Channel *chanPtr, |
| ︙ | ︙ | |||
2965 2966 2967 2968 2969 2970 2971 | MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp, const char *modeString, int *seekFlagPtr, int *binaryPtr); MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, | | | 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 | MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp, const char *modeString, int *seekFlagPtr, int *binaryPtr); MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, TCL_HASH_TYPE *sizePtr); MODULE_SCOPE int TclGetLoadedLibraries(Tcl_Interp *interp, const char *targetName, const char *packageName); MODULE_SCOPE int TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *, Tcl_WideInt *); MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern, Tcl_Obj *unquotedPrefix, int globFlags, |
| ︙ | ︙ | |||
3003 3004 3005 3006 3007 3008 3009 | MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp); MODULE_SCOPE void TclInitNamespaceSubsystem(void); MODULE_SCOPE void TclInitNotifier(void); MODULE_SCOPE void TclInitObjSubsystem(void); MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); MODULE_SCOPE int TclIsDigitProc(int byte); MODULE_SCOPE int TclIsBareword(int byte); | | > > > > > > | | > > > > > | | 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 | MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp); MODULE_SCOPE void TclInitNamespaceSubsystem(void); MODULE_SCOPE void TclInitNotifier(void); MODULE_SCOPE void TclInitObjSubsystem(void); MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); MODULE_SCOPE int TclIsDigitProc(int byte); MODULE_SCOPE int TclIsBareword(int byte); MODULE_SCOPE Tcl_Obj * TclJoinPath(size_t elements, Tcl_Obj * const objv[], int forceRelative); MODULE_SCOPE int MakeTildeRelativePath(Tcl_Interp *interp, const char *user, const char *subPath, Tcl_DString *dsPtr); MODULE_SCOPE Tcl_Obj * TclGetHomeDirObj(Tcl_Interp *interp, const char *user); MODULE_SCOPE Tcl_Obj * TclResolveTildePath(Tcl_Interp *interp, Tcl_Obj *pathObj); MODULE_SCOPE Tcl_Obj * TclResolveTildePathList(Tcl_Obj *pathsObj); MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result); MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *argPtr); MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t indexCount, Tcl_Obj *const indexArray[]); /* TIP #280 */ MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, size_t line, int n, int *lines, Tcl_Obj *const *elems); MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Obj *listPtr, ssize_t fromIdx, ssize_t toIdx); MODULE_SCOPE int TclListObjAppendElements(Tcl_Interp *interp, Tcl_Obj *toObj, ssize_t elemCount, Tcl_Obj *const elemObjv[]); MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Obj *listPtr, size_t fromIdx, size_t toIdx); MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *indexPtr, Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t indexCount, Tcl_Obj *const indexArray[], Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name, const EnsembleImplMap map[]); MODULE_SCOPE int TclMaxListLength(const char *bytes, ssize_t numBytes, const char **endPtr); MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, |
| ︙ | ︙ | |||
3060 3061 3062 3063 3064 3065 3066 | int code, int level, Tcl_Obj *returnOpts); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, size_t len); | | | | | | | | | | | 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 | int code, int level, Tcl_Obj *returnOpts); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, size_t len); MODULE_SCOPE void TclpAlertNotifier(void *clientData); MODULE_SCOPE void *TclpNotifierData(void); MODULE_SCOPE void TclpServiceModeHook(int mode); MODULE_SCOPE void TclpSetTimer(const Tcl_Time *timePtr); MODULE_SCOPE int TclpWaitForEvent(const Tcl_Time *timePtr); MODULE_SCOPE void TclpCreateFileHandler(int fd, int mask, Tcl_FileProc *proc, void *clientData); MODULE_SCOPE int TclpDeleteFile(const void *path); MODULE_SCOPE void TclpDeleteFileHandler(int fd); MODULE_SCOPE void TclpFinalizeCondition(Tcl_Condition *condPtr); MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); MODULE_SCOPE void TclpFinalizeNotifier(void *clientData); MODULE_SCOPE void TclpFinalizePipes(void); MODULE_SCOPE void TclpFinalizeSockets(void); MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, struct addrinfo **addrlist, const char *host, int port, int willBind, const char **errorMsgPtr); MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, size_t stackSize, int flags); MODULE_SCOPE size_t TclpFindVariable(const char *name, size_t *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE void *TclpInitNotifier(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void); MODULE_SCOPE void TclpGlobalLock(void); MODULE_SCOPE void TclpGlobalUnlock(void); MODULE_SCOPE int TclpMatchFiles(Tcl_Interp *interp, char *separators, Tcl_DString *dirPtr, char *pattern, char *tail); MODULE_SCOPE int TclpObjNormalizePath(Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint); MODULE_SCOPE void TclpNativeJoinPath(Tcl_Obj *prefix, const char *joining); MODULE_SCOPE Tcl_Obj * TclpNativeSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr); MODULE_SCOPE Tcl_PathType TclpGetNativePathType(Tcl_Obj *pathPtr, size_t *driveNameLengthPtr, Tcl_Obj **driveNameRef); MODULE_SCOPE int TclCrossFilesystemCopy(Tcl_Interp *interp, Tcl_Obj *source, Tcl_Obj *target); MODULE_SCOPE int TclpMatchInDirectory(Tcl_Interp *interp, Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, const char *pattern, Tcl_GlobTypeData *types); MODULE_SCOPE void *TclpGetNativeCwd(void *clientData); MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep; MODULE_SCOPE Tcl_Obj * TclpObjLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkType); MODULE_SCOPE int TclpObjChdir(Tcl_Obj *pathPtr); MODULE_SCOPE Tcl_Channel TclpOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); |
| ︙ | ︙ | |||
3146 3147 3148 3149 3150 3151 3152 | MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Command *cmdPtr); MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr); MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue, Tcl_Encoding encoding); MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result); MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, | | | | | | 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 | MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Command *cmdPtr); MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr); MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue, Tcl_Encoding encoding); MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result); MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, Tcl_Obj *const *objv, size_t objc, size_t subIdx, Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, size_t numBytes); typedef int (*memCmpFn_t)(const void*, const void*, size_t); MODULE_SCOPE int TclStringCmp(Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr, int checkEq, int nocase, ssize_t reqlength); MODULE_SCOPE int TclStringCmpOpts(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int *nocase, int *reqlength); MODULE_SCOPE int TclStringMatch(const char *str, size_t strLen, const char *pattern, int ptnLen, int flags); MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, Tcl_Obj *patternObj, int flags); MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes, size_t numBytes, int flags, size_t line, struct CompileEnv *envPtr); MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, size_t numOpts, Tcl_Obj *const opts[], int *flagPtr); MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes, size_t numBytes, int flags, Tcl_Parse *parsePtr, Tcl_InterpState *statePtr); MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, size_t count, int *tokensLeftPtr, size_t line, int *clNextOuter, const char *outerScript); MODULE_SCOPE size_t TclTrim(const char *bytes, size_t numBytes, const char *trim, size_t numTrim, size_t *trimRight); MODULE_SCOPE size_t TclTrimLeft(const char *bytes, size_t numBytes, const char *trim, size_t numTrim); MODULE_SCOPE size_t TclTrimRight(const char *bytes, size_t numBytes, const char *trim, size_t numTrim); |
| ︙ | ︙ | |||
3307 3308 3309 3310 3311 3312 3313 | int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp); MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int index, int pathc, Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, | | | 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 | int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp); MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int index, int pathc, Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t pathc, Tcl_Obj *const pathv[]); MODULE_SCOPE int Tcl_DisassembleObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* Assemble command function */ MODULE_SCOPE int Tcl_AssembleObjCmd(void *clientData, Tcl_Interp *interp, int objc, |
| ︙ | ︙ | |||
4434 4435 4436 4437 4438 4439 4440 |
*/
#define TclInitStringRep(objPtr, bytePtr, len) \
if ((len) == 0) { \
(objPtr)->bytes = &tclEmptyString; \
(objPtr)->length = 0; \
} else { \
| | | 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 |
*/
#define TclInitStringRep(objPtr, bytePtr, len) \
if ((len) == 0) { \
(objPtr)->bytes = &tclEmptyString; \
(objPtr)->length = 0; \
} else { \
(objPtr)->bytes = (char *)Tcl_Alloc((len) + 1U); \
memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)); \
(objPtr)->bytes[len] = '\0'; \
(objPtr)->length = (len); \
}
/*
*----------------------------------------------------------------
|
| ︙ | ︙ | |||
4575 4576 4577 4578 4579 4580 4581 | #endif /* Token growth tuning, default to the general value. */ #ifndef TCL_MIN_TOKEN_GROWTH #define TCL_MIN_TOKEN_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Token) #endif | < | < < < < | < < < < < < | 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 |
#endif
/* Token growth tuning, default to the general value. */
#ifndef TCL_MIN_TOKEN_GROWTH
#define TCL_MIN_TOKEN_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Token)
#endif
#define TclGrowTokenArray(tokenPtr, used, available, append, staticPtr) \
do { \
size_t _needed = (used) + (append); \
if (_needed > (available)) { \
size_t allocated = 2 * _needed; \
Tcl_Token *oldPtr = (tokenPtr); \
Tcl_Token *newPtr; \
if (oldPtr == (staticPtr)) { \
oldPtr = NULL; \
} \
newPtr = (Tcl_Token *)Tcl_AttemptRealloc((char *) oldPtr, \
allocated * sizeof(Tcl_Token)); \
if (newPtr == NULL) { \
allocated = _needed + (append) + TCL_MIN_TOKEN_GROWTH; \
newPtr = (Tcl_Token *)Tcl_Realloc((char *) oldPtr, \
allocated * sizeof(Tcl_Token)); \
} \
(available) = allocated; \
if (oldPtr == NULL) { \
memcpy(newPtr, staticPtr, \
(used) * sizeof(Tcl_Token)); \
|
| ︙ | ︙ | |||
4636 4637 4638 4639 4640 4641 4642 | #if TCL_UTF_MAX > 3 #define TclUtfToUniChar(str, chPtr) \ (((UCHAR(*(str))) < 0x80) ? \ ((*(chPtr) = UCHAR(*(str))), 1) \ : Tcl_UtfToUniChar(str, chPtr)) #else #define TclUtfToUniChar(str, chPtr) \ | | | | | 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 |
#if TCL_UTF_MAX > 3
#define TclUtfToUniChar(str, chPtr) \
(((UCHAR(*(str))) < 0x80) ? \
((*(chPtr) = UCHAR(*(str))), 1) \
: Tcl_UtfToUniChar(str, chPtr))
#else
#define TclUtfToUniChar(str, chPtr) \
(((UCHAR(*(str))) < 0x80) ? \
((*(chPtr) = UCHAR(*(str))), 1) \
: Tcl_UtfToChar16(str, chPtr))
#endif
/*
*----------------------------------------------------------------
* Macro counterpart of the Tcl_NumUtfChars() function. To be used in speed-
* -sensitive points where it pays to avoid a function call in the common case
* of counting along a string of all one-byte characters. The ANSI C
* "prototype" for this macro is:
*
* MODULE_SCOPE void TclNumUtfCharsM(size_t numChars, const char *bytes,
* size_t numBytes);
*----------------------------------------------------------------
*/
#define TclNumUtfCharsM(numChars, bytes, numBytes) \
do { \
size_t _count, _i = (numBytes); \
|
| ︙ | ︙ |
Changes to generic/tclIntDecls.h.
| ︙ | ︙ | |||
83 84 85 86 87 88 89 | /* Slot 17 is reserved */ /* Slot 18 is reserved */ /* Slot 19 is reserved */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ /* 22 */ EXTERN int TclFindElement(Tcl_Interp *interp, | | | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 | /* Slot 17 is reserved */ /* Slot 18 is reserved */ /* Slot 19 is reserved */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ /* 22 */ EXTERN int TclFindElement(Tcl_Interp *interp, const char *listStr, size_t listLength, const char **elementPtr, const char **nextPtr, size_t *sizePtr, int *bracePtr); /* 23 */ EXTERN Proc * TclFindProc(Interp *iPtr, const char *procName); /* 24 */ EXTERN size_t TclFormatInt(char *buffer, Tcl_WideInt n); |
| ︙ | ︙ | |||
117 118 119 120 121 122 123 | EXTERN int TclGetNamespaceForQualName(Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, const char **simpleNamePtr); /* 39 */ | | | 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 | EXTERN int TclGetNamespaceForQualName(Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, const char **simpleNamePtr); /* 39 */ EXTERN Tcl_ObjCmdProc * TclGetObjInterpProc(void); /* 40 */ EXTERN int TclGetOpenMode(Tcl_Interp *interp, const char *str, int *seekFlagPtr); /* 41 */ EXTERN Tcl_Command TclGetOriginalCommand(Tcl_Command command); /* 42 */ EXTERN const char * TclpGetUserHome(const char *name, |
| ︙ | ︙ | |||
305 306 307 308 309 310 311 | /* 141 */ EXTERN const char * TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 142 */ EXTERN int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, void *clientData); /* 143 */ | | | 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 | /* 141 */ EXTERN const char * TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 142 */ EXTERN int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, void *clientData); /* 143 */ EXTERN size_t TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 144 */ EXTERN void TclHideLiteral(Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 145 */ EXTERN const struct AuxDataType * TclGetAuxDataType(const char *typeName); /* 146 */ |
| ︙ | ︙ | |||
354 355 356 357 358 359 360 | EXTERN const void * TclGetInstructionTable(void); /* 164 */ EXTERN void TclExpandCodeArray(void *envPtr); /* 165 */ EXTERN void TclpSetInitialEncodings(void); /* 166 */ EXTERN int TclListObjSetElement(Tcl_Interp *interp, | | | 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 | EXTERN const void * TclGetInstructionTable(void); /* 164 */ EXTERN void TclExpandCodeArray(void *envPtr); /* 165 */ EXTERN void TclpSetInitialEncodings(void); /* 166 */ EXTERN int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t index, Tcl_Obj *valuePtr); /* Slot 167 is reserved */ /* Slot 168 is reserved */ /* 169 */ EXTERN int TclpUtfNcmp2(const char *s1, const char *s2, size_t n); /* 170 */ |
| ︙ | ︙ | |||
540 541 542 543 544 545 546 | /* 249 */ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 250 */ EXTERN void TclSetChildCancelFlags(Tcl_Interp *interp, int flags, int force); /* 251 */ | | | 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 | /* 249 */ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 250 */ EXTERN void TclSetChildCancelFlags(Tcl_Interp *interp, int flags, int force); /* 251 */ EXTERN size_t TclRegisterLiteral(void *envPtr, const char *bytes, ssize_t length, int flags); /* 252 */ EXTERN Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 253 */ EXTERN Tcl_Obj * TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr, |
| ︙ | ︙ | |||
572 573 574 575 576 577 578 579 580 581 582 583 584 585 |
EXTERN void TclStaticLibrary(Tcl_Interp *interp,
const char *prefix,
Tcl_LibraryInitProc *initProc,
Tcl_LibraryInitProc *safeInitProc);
/* 258 */
EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj);
typedef struct TclIntStubs {
int magic;
void *hooks;
void (*reserved0)(void);
void (*reserved1)(void);
| > > > > > > > | 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 |
EXTERN void TclStaticLibrary(Tcl_Interp *interp,
const char *prefix,
Tcl_LibraryInitProc *initProc,
Tcl_LibraryInitProc *safeInitProc);
/* 258 */
EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj);
/* Slot 259 is reserved */
/* 260 */
EXTERN Tcl_Obj * TclListTestObj(int length, int leadingSpace,
int endSpace);
/* 261 */
EXTERN void TclListObjValidate(Tcl_Interp *interp,
Tcl_Obj *listObj);
typedef struct TclIntStubs {
int magic;
void *hooks;
void (*reserved0)(void);
void (*reserved1)(void);
|
| ︙ | ︙ | |||
599 600 601 602 603 604 605 |
void (*reserved15)(void);
void (*tclExprFloatError) (Tcl_Interp *interp, double value); /* 16 */
void (*reserved17)(void);
void (*reserved18)(void);
void (*reserved19)(void);
void (*reserved20)(void);
void (*reserved21)(void);
| | | | 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 |
void (*reserved15)(void);
void (*tclExprFloatError) (Tcl_Interp *interp, double value); /* 16 */
void (*reserved17)(void);
void (*reserved18)(void);
void (*reserved19)(void);
void (*reserved20)(void);
void (*reserved21)(void);
int (*tclFindElement) (Tcl_Interp *interp, const char *listStr, size_t listLength, const char **elementPtr, const char **nextPtr, size_t *sizePtr, int *bracePtr); /* 22 */
Proc * (*tclFindProc) (Interp *iPtr, const char *procName); /* 23 */
size_t (*tclFormatInt) (char *buffer, Tcl_WideInt n); /* 24 */
void (*tclFreePackageInfo) (Interp *iPtr); /* 25 */
void (*reserved26)(void);
void (*reserved27)(void);
Tcl_Channel (*tclpGetDefaultStdChannel) (int type); /* 28 */
void (*reserved29)(void);
void (*reserved30)(void);
const char * (*tclGetExtension) (const char *name); /* 31 */
int (*tclGetFrame) (Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr); /* 32 */
void (*reserved33)(void);
void (*reserved34)(void);
void (*reserved35)(void);
void (*reserved36)(void);
void (*reserved37)(void);
int (*tclGetNamespaceForQualName) (Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, const char **simpleNamePtr); /* 38 */
Tcl_ObjCmdProc * (*tclGetObjInterpProc) (void); /* 39 */
int (*tclGetOpenMode) (Tcl_Interp *interp, const char *str, int *seekFlagPtr); /* 40 */
Tcl_Command (*tclGetOriginalCommand) (Tcl_Command command); /* 41 */
const char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */
void (*reserved43)(void);
void (*reserved44)(void);
int (*tclHideUnsafeCommands) (Tcl_Interp *interp); /* 45 */
int (*tclInExit) (void); /* 46 */
|
| ︙ | ︙ | |||
720 721 722 723 724 725 726 |
void (*reserved136)(void);
void (*reserved137)(void);
const char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */
void (*reserved139)(void);
void (*reserved140)(void);
const char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */
int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, void *clientData); /* 142 */
| | | 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 |
void (*reserved136)(void);
void (*reserved137)(void);
const char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */
void (*reserved139)(void);
void (*reserved140)(void);
const char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */
int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, void *clientData); /* 142 */
size_t (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */
void (*tclHideLiteral) (Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 144 */
const struct AuxDataType * (*tclGetAuxDataType) (const char *typeName); /* 145 */
TclHandle (*tclHandleCreate) (void *ptr); /* 146 */
void (*tclHandleFree) (TclHandle handle); /* 147 */
TclHandle (*tclHandlePreserve) (TclHandle handle); /* 148 */
void (*tclHandleRelease) (TclHandle handle); /* 149 */
int (*tclRegAbout) (Tcl_Interp *interp, Tcl_RegExp re); /* 150 */
|
| ︙ | ︙ | |||
743 744 745 746 747 748 749 |
void (*reserved159)(void);
void (*reserved160)(void);
int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */
void (*tclChannelEventScriptInvoker) (void *clientData, int flags); /* 162 */
const void * (*tclGetInstructionTable) (void); /* 163 */
void (*tclExpandCodeArray) (void *envPtr); /* 164 */
void (*tclpSetInitialEncodings) (void); /* 165 */
| | | 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 |
void (*reserved159)(void);
void (*reserved160)(void);
int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */
void (*tclChannelEventScriptInvoker) (void *clientData, int flags); /* 162 */
const void * (*tclGetInstructionTable) (void); /* 163 */
void (*tclExpandCodeArray) (void *envPtr); /* 164 */
void (*tclpSetInitialEncodings) (void); /* 165 */
int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t index, Tcl_Obj *valuePtr); /* 166 */
void (*reserved167)(void);
void (*reserved168)(void);
int (*tclpUtfNcmp2) (const char *s1, const char *s2, size_t n); /* 169 */
int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, size_t objc, Tcl_Obj *const objv[]); /* 170 */
int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, size_t objc, Tcl_Obj *const objv[]); /* 171 */
int (*tclInThreadExit) (void); /* 172 */
int (*tclUniCharMatch) (const Tcl_UniChar *string, size_t strLen, const Tcl_UniChar *pattern, size_t ptnLen, int flags); /* 173 */
|
| ︙ | ︙ | |||
828 829 830 831 832 833 834 |
Tcl_HashTable * (*tclGetNamespaceChildTable) (Tcl_Namespace *nsPtr); /* 244 */
Tcl_HashTable * (*tclGetNamespaceCommandTable) (Tcl_Namespace *nsPtr); /* 245 */
int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, size_t numRemoved, size_t numInserted, Tcl_Obj *const *objv); /* 246 */
void (*tclResetRewriteEnsemble) (Tcl_Interp *interp, int isRootEnsemble); /* 247 */
int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, long long toRead, Tcl_Obj *cmdPtr); /* 248 */
char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */
void (*tclSetChildCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */
| | > > > | 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 |
Tcl_HashTable * (*tclGetNamespaceChildTable) (Tcl_Namespace *nsPtr); /* 244 */
Tcl_HashTable * (*tclGetNamespaceCommandTable) (Tcl_Namespace *nsPtr); /* 245 */
int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, size_t numRemoved, size_t numInserted, Tcl_Obj *const *objv); /* 246 */
void (*tclResetRewriteEnsemble) (Tcl_Interp *interp, int isRootEnsemble); /* 247 */
int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, long long toRead, Tcl_Obj *cmdPtr); /* 248 */
char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */
void (*tclSetChildCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */
size_t (*tclRegisterLiteral) (void *envPtr, const char *bytes, ssize_t length, int flags); /* 251 */
Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 252 */
Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 253 */
Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); /* 254 */
int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */
int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 256 */
void (*tclStaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 257 */
Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */
void (*reserved259)(void);
Tcl_Obj * (*tclListTestObj) (int length, int leadingSpace, int endSpace); /* 260 */
void (*tclListObjValidate) (Tcl_Interp *interp, Tcl_Obj *listObj); /* 261 */
} TclIntStubs;
extern const TclIntStubs *tclIntStubsPtr;
#ifdef __cplusplus
}
#endif
|
| ︙ | ︙ | |||
1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 | (tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */ #define TclPtrUnsetVar \ (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */ #define TclStaticLibrary \ (tclIntStubsPtr->tclStaticLibrary) /* 257 */ #define TclpCreateTemporaryDirectory \ (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #if defined(USE_TCL_STUBS) #undef Tcl_StaticLibrary #define Tcl_StaticLibrary \ (tclIntStubsPtr->tclStaticLibrary) #endif /* defined(USE_TCL_STUBS) */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLINTDECLS */ | > > > > > > > | 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 | (tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */ #define TclPtrUnsetVar \ (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */ #define TclStaticLibrary \ (tclIntStubsPtr->tclStaticLibrary) /* 257 */ #define TclpCreateTemporaryDirectory \ (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */ /* Slot 259 is reserved */ #define TclListTestObj \ (tclIntStubsPtr->tclListTestObj) /* 260 */ #define TclListObjValidate \ (tclIntStubsPtr->tclListObjValidate) /* 261 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #if defined(USE_TCL_STUBS) #undef Tcl_StaticLibrary #define Tcl_StaticLibrary \ (tclIntStubsPtr->tclStaticLibrary) #endif /* defined(USE_TCL_STUBS) */ #undef TclObjInterpProc #define TclObjInterpProc TclGetObjInterpProc() #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLINTDECLS */ |
Changes to generic/tclInterp.c.
| ︙ | ︙ | |||
1193 1194 1195 1196 1197 1198 1199 |
int
Tcl_CreateAlias(
Tcl_Interp *childInterp, /* Interpreter for source command. */
const char *childCmd, /* Command to install in child. */
Tcl_Interp *targetInterp, /* Interpreter for target command. */
const char *targetCmd, /* Name of target command. */
| | | | 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 |
int
Tcl_CreateAlias(
Tcl_Interp *childInterp, /* Interpreter for source command. */
const char *childCmd, /* Command to install in child. */
Tcl_Interp *targetInterp, /* Interpreter for target command. */
const char *targetCmd, /* Name of target command. */
size_t argc, /* How many additional arguments? */
const char *const *argv) /* These are the additional args. */
{
Tcl_Obj *childObjPtr, *targetObjPtr;
Tcl_Obj **objv;
size_t i;
int result;
objv = (Tcl_Obj **)TclStackAlloc(childInterp, sizeof(Tcl_Obj *) * argc);
for (i = 0; i < argc; i++) {
objv[i] = Tcl_NewStringObj(argv[i], -1);
Tcl_IncrRefCount(objv[i]);
}
|
| ︙ | ︙ | |||
1248 1249 1250 1251 1252 1253 1254 |
int
Tcl_CreateAliasObj(
Tcl_Interp *childInterp, /* Interpreter for source command. */
const char *childCmd, /* Command to install in child. */
Tcl_Interp *targetInterp, /* Interpreter for target command. */
const char *targetCmd, /* Name of target command. */
| | | 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 |
int
Tcl_CreateAliasObj(
Tcl_Interp *childInterp, /* Interpreter for source command. */
const char *childCmd, /* Command to install in child. */
Tcl_Interp *targetInterp, /* Interpreter for target command. */
const char *targetCmd, /* Name of target command. */
size_t objc, /* How many additional arguments? */
Tcl_Obj *const objv[]) /* Argument vector. */
{
Tcl_Obj *childObjPtr, *targetObjPtr;
int result;
childObjPtr = Tcl_NewStringObj(childCmd, -1);
Tcl_IncrRefCount(childObjPtr);
|
| ︙ | ︙ | |||
1825 1826 1827 1828 1829 1830 1831 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument vector. */
{
Alias *aliasPtr = (Alias *)clientData;
int prefc, cmdc, i;
Tcl_Obj **prefv, **cmdv;
Tcl_Obj *listPtr;
| | > > | | | > > | > | | | 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 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 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument vector. */
{
Alias *aliasPtr = (Alias *)clientData;
int prefc, cmdc, i;
Tcl_Obj **prefv, **cmdv;
Tcl_Obj *listPtr;
ListRep listRep;
int flags = TCL_EVAL_INVOKE;
/*
* Append the arguments to the command prefix and invoke the command in
* the target interp's global namespace.
*/
prefc = aliasPtr->objc;
prefv = &aliasPtr->objPtr;
cmdc = prefc + objc - 1;
/* TODO - encapsulate this into tclListObj.c */
listPtr = Tcl_NewListObj(cmdc, NULL);
ListObjGetRep(listPtr, &listRep);
cmdv = ListRepElementsBase(&listRep);
listRep.storePtr->numUsed = cmdc;
if (listRep.spanPtr) {
listRep.spanPtr->spanStart = listRep.storePtr->firstUsed;
listRep.spanPtr->spanLength = listRep.storePtr->numUsed;
}
prefv = &aliasPtr->objPtr;
memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *));
memcpy(cmdv+prefc, objv+1, (objc-1) * sizeof(Tcl_Obj *));
for (i=0; i<cmdc; i++) {
Tcl_IncrRefCount(cmdv[i]);
}
/*
* Use the ensemble rewriting machinery to ensure correct error messages:
|
| ︙ | ︙ | |||
2314 2315 2316 2317 2318 2319 2320 |
Tcl_Interp *interp, /* Interp. to start search from. */
Tcl_Obj *pathPtr) /* List object containing name of interp. to
* be found. */
{
Tcl_HashEntry *hPtr; /* Search element. */
Child *childPtr; /* Interim child record. */
Tcl_Obj **objv;
| | | | 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 |
Tcl_Interp *interp, /* Interp. to start search from. */
Tcl_Obj *pathPtr) /* List object containing name of interp. to
* be found. */
{
Tcl_HashEntry *hPtr; /* Search element. */
Child *childPtr; /* Interim child record. */
Tcl_Obj **objv;
size_t objc, i;
Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */
InterpInfo *parentInfoPtr;
if (TclListObjGetElementsM(interp, pathPtr, &objc, &objv) != TCL_OK) {
return NULL;
}
searchInterp = interp;
for (i = 0; i < objc; i++) {
parentInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo;
hPtr = Tcl_FindHashEntry(&parentInfoPtr->parent.childTable,
|
| ︙ | ︙ | |||
2372 2373 2374 2375 2376 2377 2378 |
ChildBgerror(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */
int objc, /* Set or Query. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
if (objc) {
| | | | 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 |
ChildBgerror(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */
int objc, /* Set or Query. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
if (objc) {
size_t length;
if (TCL_ERROR == TclListObjLengthM(NULL, objv[0], &length)
|| (length < 1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cmdPrefix must be list of length >= 1", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BGERRORFORMAT", NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2418 2419 2420 2421 2422 2423 2424 |
int safe) /* Should we make it "safe"? */
{
Tcl_Interp *parentInterp, *childInterp;
Child *childPtr;
InterpInfo *parentInfoPtr;
Tcl_HashEntry *hPtr;
const char *path;
| | > | | 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 |
int safe) /* Should we make it "safe"? */
{
Tcl_Interp *parentInterp, *childInterp;
Child *childPtr;
InterpInfo *parentInfoPtr;
Tcl_HashEntry *hPtr;
const char *path;
int isNew;
size_t objc;
Tcl_Obj **objv;
if (TclListObjGetElementsM(interp, pathPtr, &objc, &objv) != TCL_OK) {
return NULL;
}
if (objc < 2) {
parentInterp = interp;
path = TclGetString(pathPtr);
} else {
Tcl_Obj *objPtr;
|
| ︙ | ︙ | |||
2986 2987 2988 2989 2990 2991 2992 |
ChildRecursionLimit(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */
int objc, /* Set or Query. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
Interp *iPtr;
| | | | | | | 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 |
ChildRecursionLimit(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */
int objc, /* Set or Query. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
Interp *iPtr;
Tcl_WideInt limit;
if (objc) {
if (Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("permission denied: "
"safe interpreters cannot change recursion limit", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
NULL);
return TCL_ERROR;
}
if (TclGetWideIntFromObj(interp, objv[0], &limit) == TCL_ERROR) {
return TCL_ERROR;
}
if (limit <= 0 || (size_t)limit >= ((Tcl_WideUInt)WIDE_MAX & TCL_INDEX_NONE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"recursion limit must be > 0 and < %" TCL_LL_MODIFIER "u", (Tcl_WideUInt)WIDE_MAX & TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADLIMIT",
NULL);
return TCL_ERROR;
}
Tcl_SetRecursionLimit(childInterp, limit);
iPtr = (Interp *) childInterp;
if (interp == childInterp && iPtr->numLevels > (size_t)limit) {
|
| ︙ | ︙ | |||
3975 3976 3977 3978 3979 3980 3981 |
*
*----------------------------------------------------------------------
*/
void
Tcl_LimitSetCommands(
Tcl_Interp *interp,
| | | 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 |
*
*----------------------------------------------------------------------
*/
void
Tcl_LimitSetCommands(
Tcl_Interp *interp,
size_t commandLimit)
{
Interp *iPtr = (Interp *) interp;
iPtr->limit.cmdCount = commandLimit;
iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS;
}
|
| ︙ | ︙ | |||
4306 4307 4308 4309 4310 4311 4312 |
Tcl_Panic("installing limit callback to the limited interpreter");
}
key.interp = targetInterp;
key.type = type;
if (scriptObj == NULL) {
| | | 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 |
Tcl_Panic("installing limit callback to the limited interpreter");
}
key.interp = targetInterp;
key.type = type;
if (scriptObj == NULL) {
hashPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, &key);
if (hashPtr != NULL) {
Tcl_LimitRemoveHandler(targetInterp, type, CallScriptLimitCallback,
Tcl_GetHashValue(hashPtr));
}
return;
}
|
| ︙ | ︙ | |||
4509 4510 4511 4512 4513 4514 4515 |
if (objc == consumedObjc) {
Tcl_Obj *dictPtr;
TclNewObj(dictPtr);
key.interp = childInterp;
key.type = TCL_LIMIT_COMMANDS;
| | | 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 |
if (objc == consumedObjc) {
Tcl_Obj *dictPtr;
TclNewObj(dictPtr);
key.interp = childInterp;
key.type = TCL_LIMIT_COMMANDS;
hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, &key);
if (hPtr != NULL) {
limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr);
if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1),
limitCBPtr->scriptObj);
} else {
goto putEmptyCommandInDict;
|
| ︙ | ︙ | |||
4551 4552 4553 4554 4555 4556 4557 |
0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_CMD:
key.interp = childInterp;
key.type = TCL_LIMIT_COMMANDS;
| | | 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 |
0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_CMD:
key.interp = childInterp;
key.type = TCL_LIMIT_COMMANDS;
hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, &key);
if (hPtr != NULL) {
limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr);
if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
Tcl_SetObjResult(interp, limitCBPtr->scriptObj);
}
}
break;
|
| ︙ | ︙ | |||
4697 4698 4699 4700 4701 4702 4703 |
if (objc == consumedObjc) {
Tcl_Obj *dictPtr;
TclNewObj(dictPtr);
key.interp = childInterp;
key.type = TCL_LIMIT_TIME;
| | | 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 |
if (objc == consumedObjc) {
Tcl_Obj *dictPtr;
TclNewObj(dictPtr);
key.interp = childInterp;
key.type = TCL_LIMIT_TIME;
hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, &key);
if (hPtr != NULL) {
limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr);
if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1),
limitCBPtr->scriptObj);
} else {
goto putEmptyCommandInDict;
|
| ︙ | ︙ | |||
4745 4746 4747 4748 4749 4750 4751 |
0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_CMD:
key.interp = childInterp;
key.type = TCL_LIMIT_TIME;
| | | 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 |
0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_CMD:
key.interp = childInterp;
key.type = TCL_LIMIT_TIME;
hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, &key);
if (hPtr != NULL) {
limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr);
if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
Tcl_SetObjResult(interp, limitCBPtr->scriptObj);
}
}
break;
|
| ︙ | ︙ |
Changes to generic/tclLink.c.
| ︙ | ︙ | |||
91 92 93 94 95 96 97 | #define LINK_ALLOC_ADDR 4 #define LINK_ALLOC_LAST 8 /* * Forward references to functions defined later in this file: */ | | | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | #define LINK_ALLOC_ADDR 4 #define LINK_ALLOC_LAST 8 /* * Forward references to functions defined later in this file: */ static char * LinkTraceProc(void *clientData,Tcl_Interp *interp, const char *name1, const char *name2, int flags); static Tcl_Obj * ObjValue(Link *linkPtr); static void LinkFree(Link *linkPtr); static int GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr); static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr); static int SetInvalidRealFromAny(Tcl_Interp *interp, |
| ︙ | ︙ | |||
523 524 525 526 527 528 529 |
static inline int
GetUWide(
Tcl_Obj *objPtr,
Tcl_WideUInt *uwidePtr)
{
Tcl_WideInt *widePtr = (Tcl_WideInt *) uwidePtr;
| | | 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 |
static inline int
GetUWide(
Tcl_Obj *objPtr,
Tcl_WideUInt *uwidePtr)
{
Tcl_WideInt *widePtr = (Tcl_WideInt *) uwidePtr;
void *clientData;
int type, intValue;
if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) {
if (type == TCL_NUMBER_INT) {
*widePtr = *((const Tcl_WideInt *) clientData);
return (*widePtr < 0);
} else if (type == TCL_NUMBER_BIG) {
|
| ︙ | ︙ | |||
627 628 629 630 631 632 633 634 |
*/
static int
SetInvalidRealFromAny(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *objPtr)
{
size_t length;
| > > < | | | 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 652 653 654 655 |
*/
static int
SetInvalidRealFromAny(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *objPtr)
{
const char *str;
const char *endPtr;
size_t length;
str = Tcl_GetStringFromObj(objPtr, &length);
if ((length == 1) && (str[0] == '.')) {
objPtr->typePtr = &invalidRealType;
objPtr->internalRep.doubleValue = 0.0;
return TCL_OK;
}
if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr,
TCL_PARSE_DECIMAL_ONLY) == TCL_OK) {
/*
* If number is followed by [eE][+-]?, then it is an invalid
* double, but it could be the start of a valid double.
*/
if (*endPtr == 'e' || *endPtr == 'E') {
++endPtr;
if (*endPtr == '+' || *endPtr == '-') {
++endPtr;
}
|
| ︙ | ︙ | |||
663 664 665 666 667 668 669 |
}
}
}
return TCL_ERROR;
}
/*
| | | | | | | | | | | | 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 |
}
}
}
return TCL_ERROR;
}
/*
* This function checks for integer representations, which are valid
* when linking with C variables, but which are invalid in other
* contexts in Tcl. Handled are "+", "-", "", "0x", "0b", "0d" and "0o"
* (upperand lowercase). See bug [39f6304c2e].
*/
static int
GetInvalidIntFromObj(
Tcl_Obj *objPtr,
int *intPtr)
{
size_t length;
const char *str = Tcl_GetStringFromObj(objPtr, &length);
if ((length == 0) || ((length == 2) && (str[0] == '0')
&& strchr("xXbBoOdD", str[1]))) {
*intPtr = 0;
return TCL_OK;
} else if ((length == 1) && strchr("+-", str[0])) {
*intPtr = (str[0] == '+');
return TCL_OK;
}
return TCL_ERROR;
}
/*
* This function checks for double representations, which are valid
* when linking with C variables, but which are invalid in other
* contexts in Tcl. Handled are "+", "-", "", ".", "0x", "0b" and "0o"
* (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e].
*/
static int
GetInvalidDoubleFromObj(
Tcl_Obj *objPtr,
double *doublePtr)
{
|
| ︙ | ︙ | |||
740 741 742 743 744 745 746 | * modification. * *---------------------------------------------------------------------- */ static char * LinkTraceProc( | | | < | 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 |
* modification.
*
*----------------------------------------------------------------------
*/
static char *
LinkTraceProc(
void *clientData, /* Contains information about the link. */
Tcl_Interp *interp, /* Interpreter containing Tcl variable. */
TCL_UNUSED(const char *) /*name1*/,
TCL_UNUSED(const char *) /*name2*/,
/* Links can only be made to global variables,
* so we can find them with need to resolve
* caller-supplied name in caller context. */
int flags) /* Miscellaneous additional information. */
{
Link *linkPtr = (Link *)clientData;
int changed;
size_t valueLength = 0;
const char *value;
char **pp;
Tcl_Obj *valueObj;
int valueInt;
Tcl_WideInt valueWide;
Tcl_WideUInt valueUWide;
double valueDouble;
size_t objc, i;
Tcl_Obj **objv;
/*
* If the variable is being unset, then just re-create it (with a trace)
* unless the whole interpreter is going away.
*/
if (flags & TCL_TRACE_UNSETS) {
|
| ︙ | ︙ | |||
943 944 945 946 947 948 949 |
((value) >= (lowerLimit) && (value) <= (upperLimit))
/*
* If we're working with an array of numbers, extract the Tcl list.
*/
if (linkPtr->flags & LINK_ALLOC_LAST) {
| | | | | 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 |
((value) >= (lowerLimit) && (value) <= (upperLimit))
/*
* If we're working with an array of numbers, extract the Tcl list.
*/
if (linkPtr->flags & LINK_ALLOC_LAST) {
if (TclListObjGetElementsM(NULL, (valueObj), &objc, &objv) == TCL_ERROR
|| objc != linkPtr->numElems) {
return (char *) "wrong dimension";
}
}
switch (linkPtr->type) {
case TCL_LINK_INT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i = 0; i < objc; i++) {
int *varPtr = &linkPtr->lastValue.iPtr[i];
if (GetInt(objv[i], varPtr)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable array must have integer values";
}
|
| ︙ | ︙ |
Changes to generic/tclListObj.c.
1 2 3 4 5 | /* * tclListObj.c -- * * This file contains functions that implement the Tcl list object type. * | < < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > | > | > > > | > > > > > > > > | | | | | < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > | > > > > > > > > > > > > | > > > > > > > > > | > > | > > > > > > > > > > > > > > > > > > > > > > > | > > > | > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > | > > > > > > > > > > > > > > > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > | > | > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > | > > > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | < | | > | > < | | > > | < | | < | | | | | | < < < | < < < | | | < > > > > > > | > > > > | | < | | > > > > > > > > > > > > > > > > > > | < < < | < < < < < | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > | > > > > | > > > > > > > > > > > > > > > > > > > > > > < | | | | > | | | < < < < | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < > > < > > > | | | | | < | | | | | | | | | < < < | < | < < < < < | | > > > | | | | | > > > > > > > > > > > | | | | | | < < < | < | < < < < < < | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | > > > > > > > > < | < < < < < < < < < | > | > > | | > > | | | | | | | | < | | < | | < | < | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | | | < | < | < | < | < < < < < < < | < < < < < < < < < < < < < < < < < | < < < < | < < | < < < | < < < < | | | | | | | < < | > | | > > > | | | | | | < < < < < | < > | > | | | < | < < < < < < < < | < < < < < < < | < | > | < | < < < | < < | | < | < > | | | < < | | | | < < < | < > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | < | < < | < < | | | | < < | > | | | < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < | < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | > | < | | | | | < | < < | | < | < | | | | > | < < > | | | | | | < < | | | | < < | < | | > > | < | < | > > | < < | | < > | | | | < < > | | | | | | > | | < < < < < < | < | > > > | | | < > | | < < < | | | > > > | < | | | < < | < | < > | | < | | | | | < | > > > > > > > | | | < < < | < < < | | < < < | < < | < < < | < < < < < < < | < < < | | | | | | | > | | > > > > | | > > > > > > | > > | > > > > > > > > > > > > > | > | > > > > > > > > > | | > > > | < > > > > > > | > > > | < < > < < > | < < < | > > > | | | | > > | < | < < > > > > > > > > > | < > | | > | | < | < < < | > > > > > > > > > > > > > > > | < < < < | < < > > | < | > > > > > > | < > | > > > > > > | > > > > > > > | | | < < > > | > > > > | < | < | > | | > > | | > > > | | > > > > | > > > > > > > > > > | | > | < > | > > > > | < > | < < | > | > > > > > > | > > | > | | | | > | < > > | < > > > > > > > | > > > | | > > > > > > > > | < | > | > > | > > > > | < < > | | > | | | | | | | | | | < < | > > | | > > > | > > > > | < > > > > > > > > > > > > > > > > > > | | > > > > > > | > > > > > > > | < < | < > > > > > > > > > | > > > > > > > > > > > > > > | < < > > > > > | > | < > | < > > > > > > | | | > > | > > > > > > > | | < < < > > > > > | < < > > > > > > | < < < > > | < | | | | > > > | | | > > > | | > | > > | | | | | | | < < | > > > > > < | | < | > | > | | | < | < | | | | > < | < | < < | < | | | | | > > > < < > | > > > > | | < < | | | | | < | | | | < | < < > | | | > | < | < < | | | | | > > | | > < > | > > > > < | | | | | | < | < | < > | < | | | | < | < | > | | | | | > | < > | > | | < < | < < | | | | < < < | < | | > | | > > < < < < < < < < | | | | | | | > > | | | | | | | | < > > > > > > > | | | | | | | | > | | > > > | > | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | < < | > | > | | | | < < < < | < | < | < | | | > > > > > > | > > > | < < < < | < < < | | > > | | | | | > | | > | > | | | | | < < < | < | < < < < < | | < < < < | | | | | < | | < > | | < < | | | | < | | < | < | < < < < | < < < < < < < < | | < < < | < < < | < | < < | | | > > > | | < | < < < < < < < < < | < < < < < | | | < < < < < < < | | | > | < < < < < | < < < | < < < < < | < | | | > > < | | < < | | | | | < | | | > | | > > | < | | | | < | < | | < | < | < > | < | < | < < > | > > > | | | > > > > | | < | | < > | | | > > > | | < | | | | | < < < < > | > > > > > > > > | > > > > | < | | | > | > | | > < | < | | < | | | > > > > > > > > > > > | < < | < | < | < < | < < < > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 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 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 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 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 219 220 221 222 223 224 225 226 227 228 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 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 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 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 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 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 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 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 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 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 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 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 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 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 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 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 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 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 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 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 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 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 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 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 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 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 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 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 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 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 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 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 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 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 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 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 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 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 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 |
/*
* tclListObj.c --
*
* This file contains functions that implement the Tcl list object type.
*
* Copyright © 2022 Ashok P. Nadkarni. All rights reserved.
*
* 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 <assert.h>
/*
* TODO - memmove is fast. Measure at what size we should prefer memmove
* (for unshared objects only) in lieu of range operations. On the other
* hand, more cache dirtied?
*/
/*
* Macros for validation and bug checking.
*/
/*
* Control whether asserts are enabled. Always enable in debug builds. In non-debug
* builds, can be set with cdebug="-DENABLE_LIST_ASSERTS" on the nmake command line.
*/
#ifdef ENABLE_LIST_ASSERTS
# ifdef NDEBUG
# undef NDEBUG /* Activate assert() macro */
# endif
#else
# ifndef NDEBUG
# define ENABLE_LIST_ASSERTS /* Always activate list asserts in debug mode */
# endif
#endif
#ifdef ENABLE_LIST_ASSERTS
#define LIST_ASSERT(cond_) assert(cond_) /* TODO - is there a Tcl-specific one? */
/*
* LIST_INDEX_ASSERT is to catch errors with negative indices and counts
* being passed AFTER validation. On Tcl9 length types are unsigned hence
* the checks against LIST_MAX. On Tcl8 length types are signed hence the
* also checks against 0.
*/
#define LIST_INDEX_ASSERT(idxarg_) \
do { \
ListSizeT idx_ = (idxarg_); /* To guard against ++ etc. */ \
LIST_ASSERT(idx_ != TCL_INDEX_NONE && idx_ < LIST_MAX); \
} while (0)
/* Ditto for counts except upper limit is different */
#define LIST_COUNT_ASSERT(countarg_) \
do { \
ListSizeT count_ = (countarg_); /* To guard against ++ etc. */ \
LIST_ASSERT(count_ != TCL_INDEX_NONE && count_ <= LIST_MAX); \
} while (0)
#else
#define LIST_ASSERT(cond_) ((void) 0)
#define LIST_INDEX_ASSERT(idx_) ((void) 0)
#define LIST_COUNT_ASSERT(count_) ((void) 0)
#endif
/* Checks for when caller should have already converted to internal list type */
#define LIST_ASSERT_TYPE(listObj_) \
LIST_ASSERT((listObj_)->typePtr == &tclListType);
/*
* If ENABLE_LIST_INVARIANTS is enabled (-DENABLE_LIST_INVARIANTS from the
* command line), the entire list internal representation is checked for
* inconsistencies. This has a non-trivial cost so has to be separately
* enabled and not part of assertions checking. However, the test suite does
* invoke ListRepValidate directly even without ENABLE_LIST_INVARIANTS.
*/
#ifdef ENABLE_LIST_INVARIANTS
#define LISTREP_CHECK(listRepPtr_) ListRepValidate(listRepPtr_, __FILE__, __LINE__)
#else
#define LISTREP_CHECK(listRepPtr_) (void) 0
#endif
/*
* Flags used for controlling behavior of allocation of list
* internal representations.
*
* If the LISTREP_PANIC_ON_FAIL bit is set, the function will panic if
* list is too large or memory cannot be allocated. Without the flag
* a NULL pointer is returned.
*
* The LISTREP_SPACE_FAVOR_NONE, LISTREP_SPACE_FAVOR_FRONT,
* LISTREP_SPACE_FAVOR_BACK, LISTREP_SPACE_ONLY_BACK flags are used to
* control additional space when allocating.
* - If none of these flags is present, the exact space requested is
* allocated, nothing more.
* - Otherwise, if only LISTREP_FAVOR_FRONT is present, extra space is
* allocated with more towards the front.
* - Conversely, if only LISTREP_FAVOR_BACK is present extra space is allocated
* with more to the back.
* - If both flags are present (LISTREP_SPACE_FAVOR_NONE), the extra space
* is equally apportioned.
* - Finally if LISTREP_SPACE_ONLY_BACK is present, ALL extra space is at
* the back.
*/
#define LISTREP_PANIC_ON_FAIL 0x00000001
#define LISTREP_SPACE_FAVOR_FRONT 0x00000002
#define LISTREP_SPACE_FAVOR_BACK 0x00000004
#define LISTREP_SPACE_ONLY_BACK 0x00000008
#define LISTREP_SPACE_FAVOR_NONE \
(LISTREP_SPACE_FAVOR_FRONT | LISTREP_SPACE_FAVOR_BACK)
#define LISTREP_SPACE_FLAGS \
(LISTREP_SPACE_FAVOR_FRONT | LISTREP_SPACE_FAVOR_BACK \
| LISTREP_SPACE_ONLY_BACK)
/*
* Prototypes for non-inline static functions defined later in this file:
*/
static int MemoryAllocationError(Tcl_Interp *, size_t size);
static int ListLimitExceededError(Tcl_Interp *);
static ListStore *ListStoreNew(ListSizeT objc, Tcl_Obj *const objv[], int flags);
static int ListRepInit(ListSizeT objc, Tcl_Obj *const objv[], int flags, ListRep *);
static int ListRepInitAttempt(Tcl_Interp *,
ListSizeT objc,
Tcl_Obj *const objv[],
ListRep *);
static void ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags);
static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr);
static int TclListObjGetRep(Tcl_Interp *, Tcl_Obj *listPtr, ListRep *repPtr);
static void ListRepRange(ListRep *srcRepPtr,
ListSizeT rangeStart,
ListSizeT rangeEnd,
int preserveSrcRep,
ListRep *rangeRepPtr);
static ListStore *ListStoreReallocate(ListStore *storePtr, ListSizeT numSlots);
static void ListRepValidate(const ListRep *repPtr, const char *file,
int lineNum);
static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
static void FreeListInternalRep(Tcl_Obj *listPtr);
static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void UpdateStringOfList(Tcl_Obj *listPtr);
/*
* The structure below defines the list Tcl object type by means of functions
* that can be invoked by generic object code.
*
* The internal representation of a list object is ListRep defined in tcl.h.
*/
const Tcl_ObjType tclListType = {
"list", /* name */
FreeListInternalRep, /* freeIntRepProc */
DupListInternalRep, /* dupIntRepProc */
UpdateStringOfList, /* updateStringProc */
SetListFromAny /* setFromAnyProc */
};
/* Macros to manipulate the List internal rep */
#define ListRepIncrRefs(repPtr_) \
do { \
(repPtr_)->storePtr->refCount++; \
if ((repPtr_)->spanPtr) \
(repPtr_)->spanPtr->refCount++; \
} while (0)
/* Returns number of free unused slots at the back of the ListRep's ListStore */
#define ListRepNumFreeTail(repPtr_) \
((repPtr_)->storePtr->numAllocated \
- ((repPtr_)->storePtr->firstUsed + (repPtr_)->storePtr->numUsed))
/* Returns number of free unused slots at the front of the ListRep's ListStore */
#define ListRepNumFreeHead(repPtr_) ((repPtr_)->storePtr->firstUsed)
/* Returns a pointer to the slot corresponding to list index listIdx_ */
#define ListRepSlotPtr(repPtr_, listIdx_) \
(&(repPtr_)->storePtr->slots[ListRepStart(repPtr_) + (listIdx_)])
/*
* Macros to replace the internal representation in a Tcl_Obj. There are
* subtle differences in each so make sure to use the right one to avoid
* memory leaks, access to freed memory and the like.
*
* ListObjStompRep - assumes the Tcl_Obj internal representation can be
* overwritten AND that the passed ListRep already has reference counts that
* include the reference from the Tcl_Obj. Basically just copies the pointers
* and sets the internal Tcl_Obj type to list
*
* ListObjOverwriteRep - like ListObjOverwriteRep but additionally
* increments reference counts on the passed ListRep. Generally used when
* the string representation of the Tcl_Obj is not to be modified.
*
* ListObjReplaceRepAndInvalidate - Like ListObjOverwriteRep but additionally
* assumes the Tcl_Obj internal rep is valid (and possibly even same as
* passed ListRep) and frees it first. Additionally invalidates the string
* representation. Generally used when modifying a Tcl_Obj value.
*/
#define ListObjStompRep(objPtr_, repPtr_) \
do { \
(objPtr_)->internalRep.twoPtrValue.ptr1 = (repPtr_)->storePtr; \
(objPtr_)->internalRep.twoPtrValue.ptr2 = (repPtr_)->spanPtr; \
(objPtr_)->typePtr = &tclListType; \
} while (0)
#define ListObjOverwriteRep(objPtr_, repPtr_) \
do { \
ListRepIncrRefs(repPtr_); \
ListObjStompRep(objPtr_, repPtr_); \
} while (0)
#define ListObjReplaceRepAndInvalidate(objPtr_, repPtr_) \
do { \
/* Note order important, don't use ListObjOverwriteRep! */ \
ListRepIncrRefs(repPtr_); \
TclFreeInternalRep(objPtr_); \
TclInvalidateStringRep(objPtr_); \
ListObjStompRep(objPtr_, repPtr_); \
} while (0)
/*
*------------------------------------------------------------------------
*
* ListSpanNew --
*
* Allocates and initializes memory for a new ListSpan. The reference
* count on the returned struct is 0.
*
* Results:
* Non-NULL pointer to the allocated ListSpan.
*
* Side effects:
* The function will panic on memory allocation failure.
*
*------------------------------------------------------------------------
*/
static inline ListSpan *
ListSpanNew(
ListSizeT firstSlot, /* Starting slot index of the span */
ListSizeT numSlots) /* Number of slots covered by the span */
{
ListSpan *spanPtr = (ListSpan *) Tcl_Alloc(sizeof(*spanPtr));
spanPtr->refCount = 0;
spanPtr->spanStart = firstSlot;
spanPtr->spanLength = numSlots;
return spanPtr;
}
/*
*------------------------------------------------------------------------
*
* ListSpanDecrRefs --
*
* Decrements the reference count on a span, freeing the memory if
* it drops to zero or less.
*
* Results:
* None.
*
* Side effects:
* The memory may be freed.
*
*------------------------------------------------------------------------
*/
static inline void
ListSpanDecrRefs(ListSpan *spanPtr)
{
if (spanPtr->refCount <= 1) {
Tcl_Free(spanPtr);
} else {
spanPtr->refCount -= 1;
}
}
/*
*------------------------------------------------------------------------
*
* ListSpanMerited --
*
* Creation of a new list may sometimes be done as a span on existing
* storage instead of allocating new. The tradeoff is that if the
* original list is released, the new span-based list may hold on to
* more memory than desired. This function implements heuristics for
* deciding which option is better.
*
* Results:
* Returns non-0 if a span-based list is likely to be more optimal
* and 0 if not.
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
static inline int
ListSpanMerited(
ListSizeT length, /* Length of the proposed span */
ListSizeT usedStorageLength, /* Number of slots currently in used */
ListSizeT allocatedStorageLength) /* Length of the currently allocation */
{
/*
TODO
- heuristics thresholds need to be determined
- currently, information about the sharing (ref count) of existing
storage is not passed. Perhaps it should be. For example if the
existing storage has a "large" ref count, then it might make sense
to do even a small span.
*/
if (length < LIST_SPAN_THRESHOLD) {
return 0;/* No span for small lists */
}
if (length < (allocatedStorageLength / 2 - allocatedStorageLength / 8)) {
return 0; /* No span if less than 3/8 of allocation */
}
if (length < usedStorageLength / 2) {
return 0; /* No span if less than half current storage */
}
return 1;
}
/*
*------------------------------------------------------------------------
*
* ListStoreUpSize --
*
* For reasons of efficiency, extra space is allocated for a ListStore
* compared to what was requested. This function calculates how many
* slots should actually be allocated for a given request size.
*
* Results:
* Number of slots to allocate.
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
static inline ListSizeT
ListStoreUpSize(ListSizeT numSlotsRequested) {
/* TODO -how much extra? May be double only for smaller requests? */
return numSlotsRequested < (LIST_MAX / 2) ? 2 * numSlotsRequested
: LIST_MAX;
}
/*
*------------------------------------------------------------------------
*
* ListRepFreeUnreferenced --
*
* Inline wrapper for ListRepUnsharedFreeUnreferenced that does quick checks
* before calling it.
*
* IMPORTANT: this function must not be called on an internal
* representation of a Tcl_Obj that is itself shared.
*
* Results:
* None.
*
* Side effects:
* See comments for ListRepUnsharedFreeUnreferenced.
*
*------------------------------------------------------------------------
*/
static inline void
ListRepFreeUnreferenced(const ListRep *repPtr)
{
if (! ListRepIsShared(repPtr) && repPtr->spanPtr) {
/* T:listrep-1.5.1 */
ListRepUnsharedFreeUnreferenced(repPtr);
}
}
/*
*------------------------------------------------------------------------
*
* ObjArrayIncrRefs --
*
* Increments the reference counts for Tcl_Obj's in a subarray.
*
* Results:
* None.
*
* Side effects:
* As above.
*
*------------------------------------------------------------------------
*/
static inline void
ObjArrayIncrRefs(
Tcl_Obj * const *objv, /* Pointer to the array */
ListSizeT startIdx, /* Starting index of subarray within objv */
ListSizeT count) /* Number of elements in the subarray */
{
Tcl_Obj * const *end;
LIST_INDEX_ASSERT(startIdx);
LIST_COUNT_ASSERT(count);
objv += startIdx;
end = objv + count;
while (objv < end) {
Tcl_IncrRefCount(*objv);
++objv;
}
}
/*
*------------------------------------------------------------------------
*
* ObjArrayDecrRefs --
*
* Decrements the reference counts for Tcl_Obj's in a subarray.
*
* Results:
* None.
*
* Side effects:
* As above.
*
*------------------------------------------------------------------------
*/
static inline void
ObjArrayDecrRefs(
Tcl_Obj * const *objv, /* Pointer to the array */
ListSizeT startIdx, /* Starting index of subarray within objv */
ListSizeT count) /* Number of elements in the subarray */
{
Tcl_Obj * const *end;
LIST_INDEX_ASSERT(startIdx);
LIST_COUNT_ASSERT(count);
objv += startIdx;
end = objv + count;
while (objv < end) {
Tcl_DecrRefCount(*objv);
++objv;
}
}
/*
*------------------------------------------------------------------------
*
* ObjArrayCopy --
*
* Copies an array of Tcl_Obj* pointers.
*
* Results:
* None.
*
* Side effects:
* Reference counts on copied Tcl_Obj's are incremented.
*
*------------------------------------------------------------------------
*/
static inline void
ObjArrayCopy(
Tcl_Obj **to, /* Destination */
ListSizeT count, /* Number of pointers to copy */
Tcl_Obj *const from[]) /* Source array of Tcl_Obj* */
{
Tcl_Obj **end;
LIST_COUNT_ASSERT(count);
end = to + count;
/* TODO - would memmove followed by separate IncrRef loop be faster? */
while (to < end) {
Tcl_IncrRefCount(*from);
*to++ = *from++;
}
}
/*
*------------------------------------------------------------------------
*
* MemoryAllocationError --
*
* Generates a memory allocation failure error.
*
* Results:
* Always TCL_ERROR.
*
* Side effects:
* Error message and code are stored in the interpreter if not NULL.
*
*------------------------------------------------------------------------
*/
static int
MemoryAllocationError(
Tcl_Interp *interp, /* Interpreter for error message. May be NULL */
ListSizeT size) /* Size of attempted allocation that failed */
{
if (interp != NULL) {
Tcl_SetObjResult(
interp,
Tcl_ObjPrintf(
"list construction failed: unable to alloc %" TCL_LL_MODIFIER
"u bytes",
(Tcl_WideInt)size));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
return TCL_ERROR;
}
/*
*------------------------------------------------------------------------
*
* ListLimitExceeded --
*
* Generates an error for exceeding maximum list size.
*
* Results:
* Always TCL_ERROR.
*
* Side effects:
* Error message and code are stored in the interpreter if not NULL.
*
*------------------------------------------------------------------------
*/
static int
ListLimitExceededError(Tcl_Interp *interp)
{
if (interp != NULL) {
Tcl_SetObjResult(
interp,
Tcl_NewStringObj("max length of a Tcl list exceeded", -1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
return TCL_ERROR;
}
/*
*------------------------------------------------------------------------
*
* ListRepUnsharedShiftDown --
*
* Shifts the "in-use" contents in the ListStore for a ListRep down
* by the given number of slots. The ListStore must be unshared and
* the free space at the front of the storage area must be big enough.
* It is the caller's responsibility to check.
*
* Results:
* None.
*
* Side effects:
* The contents of the ListRep's ListStore area are shifted down in the
* storage area. The ListRep's ListSpan is updated accordingly.
*
*------------------------------------------------------------------------
*/
static inline void
ListRepUnsharedShiftDown(ListRep *repPtr, ListSizeT shiftCount)
{
ListStore *storePtr;
LISTREP_CHECK(repPtr);
LIST_ASSERT(!ListRepIsShared(repPtr));
storePtr = repPtr->storePtr;
LIST_COUNT_ASSERT(shiftCount);
LIST_ASSERT(storePtr->firstUsed >= shiftCount);
memmove(&storePtr->slots[storePtr->firstUsed - shiftCount],
&storePtr->slots[storePtr->firstUsed],
storePtr->numUsed * sizeof(Tcl_Obj *));
storePtr->firstUsed -= shiftCount;
if (repPtr->spanPtr) {
repPtr->spanPtr->spanStart -= shiftCount;
LIST_ASSERT(repPtr->spanPtr->spanLength == storePtr->numUsed);
} else {
/*
* If there was no span, firstUsed must have been 0 (Invariant)
* AND shiftCount must have been 0 (<= firstUsed on call)
* In other words, this would have been a no-op
*/
LIST_ASSERT(storePtr->firstUsed == 0);
LIST_ASSERT(shiftCount == 0);
}
LISTREP_CHECK(repPtr);
}
/*
*------------------------------------------------------------------------
*
* ListRepUnsharedShiftUp --
*
* Shifts the "in-use" contents in the ListStore for a ListRep up
* by the given number of slots. The ListStore must be unshared and
* the free space at the back of the storage area must be big enough.
* It is the caller's responsibility to check.
* TODO - this function is not currently used.
*
* Results:
* None.
*
* Side effects:
* The contents of the ListRep's ListStore area are shifted up in the
* storage area. The ListRep's ListSpan is updated accordingly.
*
*------------------------------------------------------------------------
*/
#if 0
static inline void
ListRepUnsharedShiftUp(ListRep *repPtr, ListSizeT shiftCount)
{
ListStore *storePtr;
LISTREP_CHECK(repPtr);
LIST_ASSERT(!ListRepIsShared(repPtr));
LIST_COUNT_ASSERT(shiftCount);
storePtr = repPtr->storePtr;
LIST_ASSERT((storePtr->firstUsed + storePtr->numUsed + shiftCount)
<= storePtr->numAllocated);
memmove(&storePtr->slots[storePtr->firstUsed + shiftCount],
&storePtr->slots[storePtr->firstUsed],
storePtr->numUsed * sizeof(Tcl_Obj *));
storePtr->firstUsed += shiftCount;
if (repPtr->spanPtr) {
repPtr->spanPtr->spanStart += shiftCount;
} else {
/* No span means entire original list is span */
/* Should have been zero before shift - Invariant TBD */
LIST_ASSERT(storePtr->firstUsed == shiftCount);
repPtr->spanPtr = ListSpanNew(shiftCount, storePtr->numUsed);
}
LISTREP_CHECK(repPtr);
}
#endif
/*
*------------------------------------------------------------------------
*
* ListRepValidate --
*
* Checks all invariants for a ListRep and panics on failure.
* Note this is independent of NDEBUG, assert etc.
*
* Results:
* None.
*
* Side effects:
* Panics if any invariant is not met.
*
*------------------------------------------------------------------------
*/
static void
ListRepValidate(const ListRep *repPtr, const char *file, int lineNum)
{
ListStore *storePtr = repPtr->storePtr;
const char *condition;
(void)storePtr; /* To stop gcc from whining about unused vars */
#define INVARIANT(cond_) \
do { \
if (!(cond_)) { \
condition = #cond_; \
goto failure; \
} \
} while (0)
/* Separate each condition so line number gives exact reason for failure */
INVARIANT(storePtr != NULL);
INVARIANT(storePtr->numAllocated <= LIST_MAX);
INVARIANT(storePtr->firstUsed < storePtr->numAllocated);
INVARIANT(storePtr->numUsed <= storePtr->numAllocated);
INVARIANT(storePtr->firstUsed <= (storePtr->numAllocated - storePtr->numUsed));
if (! ListRepIsShared(repPtr)) {
/*
* If this is the only reference and there is no span, then store
* occupancy must begin at 0
*/
INVARIANT(repPtr->spanPtr || repPtr->storePtr->firstUsed == 0);
}
INVARIANT(ListRepStart(repPtr) >= storePtr->firstUsed);
INVARIANT(ListRepLength(repPtr) <= storePtr->numUsed);
INVARIANT(ListRepStart(repPtr) <= (storePtr->firstUsed + storePtr->numUsed - ListRepLength(repPtr)));
#undef INVARIANT
return;
failure:
Tcl_Panic("List internal failure in %s line %d. Condition: %s",
file,
lineNum,
condition);
}
/*
*------------------------------------------------------------------------
*
* TclListObjValidate --
*
* Wrapper around ListRepValidate. Primarily used from test suite.
*
* Results:
* None.
*
* Side effects:
* Will panic if internal structure is not consistent or if object
* cannot be converted to a list object.
*
*------------------------------------------------------------------------
*/
void
TclListObjValidate(Tcl_Interp *interp, Tcl_Obj *listObj)
{
ListRep listRep;
if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
Tcl_Panic("Object passed to TclListObjValidate cannot be converted to "
"a list object.");
}
ListRepValidate(&listRep, __FILE__, __LINE__);
}
/*
*----------------------------------------------------------------------
*
* ListStoreNew --
*
* Allocates a new ListStore with space for at least objc elements. objc
* must be > 0. If objv!=NULL, initializes with the first objc values
* in that array. If objv==NULL, initalize 0 elements, with space
* to add objc more.
*
* Normally the function allocates the exact space requested unless
* the flags arguments has any LISTREP_SPACE_*
* bits set. See the comments for those #defines.
*
* Results:
* On success, a pointer to the allocated ListStore is returned.
* On allocation failure, panics if LISTREP_PANIC_ON_FAIL is set in
* flags; otherwise returns NULL.
*
* Side effects:
* The ref counts of the elements in objv are incremented on success
* since the returned ListStore references them.
*
*----------------------------------------------------------------------
*/
static ListStore *
ListStoreNew(
ListSizeT objc,
Tcl_Obj *const objv[],
int flags)
{
ListStore *storePtr;
ListSizeT capacity;
/*
* First check to see if we'd overflow and try to allocate an object
* larger than our memory allocator allows.
*/
if (objc > LIST_MAX) {
if (flags & LISTREP_PANIC_ON_FAIL) {
Tcl_Panic("max length of a Tcl list exceeded");
}
return NULL;
}
if (flags & LISTREP_SPACE_FLAGS) {
capacity = ListStoreUpSize(objc);
} else {
capacity = objc;
}
storePtr = (ListStore *)Tcl_AttemptAlloc(LIST_SIZE(capacity));
if (storePtr == NULL && capacity != objc) {
capacity = objc; /* Try allocating exact size */
storePtr = (ListStore *)Tcl_AttemptAlloc(LIST_SIZE(capacity));
}
if (storePtr == NULL) {
if (flags & LISTREP_PANIC_ON_FAIL) {
Tcl_Panic("list creation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes",
LIST_SIZE(objc));
}
return NULL;
}
storePtr->refCount = 0;
storePtr->flags = 0;
storePtr->numAllocated = capacity;
if (capacity == objc) {
storePtr->firstUsed = 0;
} else {
ListSizeT extra = capacity - objc;
int spaceFlags = flags & LISTREP_SPACE_FLAGS;
if (spaceFlags == LISTREP_SPACE_ONLY_BACK) {
storePtr->firstUsed = 0;
} else if (spaceFlags == LISTREP_SPACE_FAVOR_FRONT) {
/* Leave more space in the front */
storePtr->firstUsed =
extra - (extra / 4); /* NOT same as 3*extra/4 */
} else if (spaceFlags == LISTREP_SPACE_FAVOR_BACK) {
/* Leave more space in the back */
storePtr->firstUsed = extra / 4;
} else {
/* Apportion equally */
storePtr->firstUsed = extra / 2;
}
}
if (objv) {
storePtr->numUsed = objc;
ObjArrayCopy(&storePtr->slots[storePtr->firstUsed], objc, objv);
} else {
storePtr->numUsed = 0;
}
return storePtr;
}
/*
*------------------------------------------------------------------------
*
* ListStoreReallocate --
*
* Reallocates the memory for a ListStore.
*
* Results:
* Pointer to the ListStore which may be the same as storePtr or pointer
* to a new block of memory. On reallocation failure, NULL is returned.
*
*
* Side effects:
* The memory pointed to by storePtr is freed if it a new block has to
* be returned.
*
*
*------------------------------------------------------------------------
*/
ListStore *
ListStoreReallocate (ListStore *storePtr, ListSizeT numSlots)
{
ListSizeT newCapacity;
ListStore *newStorePtr;
newCapacity = ListStoreUpSize(numSlots);
newStorePtr =
(ListStore *)Tcl_AttemptRealloc(storePtr, LIST_SIZE(newCapacity));
if (newStorePtr == NULL) {
newCapacity = numSlots;
newStorePtr = (ListStore *)Tcl_AttemptRealloc(storePtr,
LIST_SIZE(newCapacity));
if (newStorePtr == NULL)
return NULL;
}
/* Only the capacity has changed, fix it in the header */
newStorePtr->numAllocated = newCapacity;
return newStorePtr;
}
/*
*----------------------------------------------------------------------
*
* ListRepInit --
*
* Initializes a ListRep to hold a list internal representation
* with space for objc elements.
*
* objc must be > 0. If objv!=NULL, initializes with the first objc
* values in that array. If objv==NULL, initalize list internal rep to
* have 0 elements, with space to add objc more.
*
* Normally the function allocates the exact space requested unless
* the flags arguments has one of the LISTREP_SPACE_* bits set.
* See the comments for those #defines.
*
* The reference counts of the ListStore and ListSpan (if present)
* pointed to by the initialized repPtr are set to zero.
* Caller has to manage them as necessary.
*
* Results:
* On success, TCL_OK is returned with *listRepPtr initialized.
* On failure, panics if LISTREP_PANIC_ON_FAIL is set in flags; otherwise
* returns TCL_ERROR with *listRepPtr fields set to NULL.
*
* Side effects:
* The ref counts of the elements in objv are incremented since the
* resulting list now refers to them.
*
*----------------------------------------------------------------------
*/
static int
ListRepInit(
ListSizeT objc,
Tcl_Obj *const objv[],
int flags,
ListRep *repPtr
)
{
ListStore *storePtr;
storePtr = ListStoreNew(objc, objv, flags);
if (storePtr) {
repPtr->storePtr = storePtr;
if (storePtr->firstUsed == 0) {
repPtr->spanPtr = NULL;
} else {
repPtr->spanPtr =
ListSpanNew(storePtr->firstUsed, storePtr->numUsed);
}
return TCL_OK;
}
/*
* Initialize to keep gcc happy at the call site. Else it complains
* about possibly uninitialized use.
*/
repPtr->storePtr = NULL;
repPtr->spanPtr = NULL;
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* ListRepInitAttempt --
*
* Creates a list internal rep with space for objc elements. See
* ListRepInit for requirements for parameters (in particular objc must
* be > 0). This function only adds error messages to the interpreter if
* not NULL.
*
* The reference counts of the ListStore and ListSpan (if present)
* pointed to by the initialized repPtr are set to zero.
* Caller has to manage them as necessary.
*
* Results:
* On success, TCL_OK is returned with *listRepPtr initialized.
* On allocation failure, returnes TCL_ERROR with an error message
* in the interpreter if non-NULL.
*
* Side effects:
* The ref counts of the elements in objv are incremented since the
* resulting list now refers to them.
*
*----------------------------------------------------------------------
*/
static int
ListRepInitAttempt(
Tcl_Interp *interp,
ListSizeT objc,
Tcl_Obj *const objv[],
ListRep *repPtr)
{
int result = ListRepInit(objc, objv, 0, repPtr);
if (result != TCL_OK && interp != NULL) {
if (objc > LIST_MAX) {
ListLimitExceededError(interp);
} else {
MemoryAllocationError(interp, LIST_SIZE(objc));
}
}
return result;
}
/*
*------------------------------------------------------------------------
*
* ListRepClone --
*
* Does a deep clone of an existing ListRep.
*
* Normally the function allocates the exact space needed unless
* the flags arguments has one of the LISTREP_SPACE_* bits set.
* See the comments for those #defines.
*
* Results:
* None.
*
* Side effects:
* The toRepPtr location is initialized with the ListStore and ListSpan
* (if needed) containing a copy of the list elements in fromRepPtr.
* The function will panic if memory cannot be allocated.
*
*------------------------------------------------------------------------
*/
static void
ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags)
{
Tcl_Obj **fromObjs;
ListSizeT numFrom;
ListRepElements(fromRepPtr, numFrom, fromObjs);
ListRepInit(numFrom, fromObjs, flags | LISTREP_PANIC_ON_FAIL, toRepPtr);
}
/*
*------------------------------------------------------------------------
*
* ListRepUnsharedFreeUnreferenced --
*
* Frees any Tcl_Obj's from the "in-use" area of the ListStore for a
* ListRep that are not actually references from any lists.
*
* IMPORTANT: this function must not be called on a shared internal
* representation or the internal representation of a shared Tcl_Obj.
*
* Results:
* None.
*
* Side effects:
* The firstUsed and numUsed fields of the ListStore are updated to
* reflect the new "in-use" extent.
*
*------------------------------------------------------------------------
*/
static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr)
{
ListSizeT count;
ListStore *storePtr;
ListSpan *spanPtr;
LIST_ASSERT(!ListRepIsShared(repPtr));
LISTREP_CHECK(repPtr);
storePtr = repPtr->storePtr;
spanPtr = repPtr->spanPtr;
if (spanPtr == NULL) {
LIST_ASSERT(storePtr->firstUsed == 0); /* Invariant TBD */
return;
}
/* Collect garbage at front */
count = spanPtr->spanStart - storePtr->firstUsed;
LIST_COUNT_ASSERT(count);
if (count > 0) {
/* T:listrep-1.5.1,6.{1:8} */
ObjArrayDecrRefs(storePtr->slots, storePtr->firstUsed, count);
storePtr->firstUsed = spanPtr->spanStart;
LIST_ASSERT(storePtr->numUsed >= count);
storePtr->numUsed -= count;
}
/* Collect garbage at back */
count = (storePtr->firstUsed + storePtr->numUsed)
- (spanPtr->spanStart + spanPtr->spanLength);
LIST_COUNT_ASSERT(count);
if (count > 0) {
/* T:listrep-6.{1:8} */
ObjArrayDecrRefs(
storePtr->slots, spanPtr->spanStart + spanPtr->spanLength, count);
LIST_ASSERT(storePtr->numUsed >= count);
storePtr->numUsed -= count;
}
LIST_ASSERT(ListRepStart(repPtr) == storePtr->firstUsed);
LIST_ASSERT(ListRepLength(repPtr) == storePtr->numUsed);
LISTREP_CHECK(repPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_NewListObj --
*
* This function is normally called when not debugging: i.e., when
* TCL_MEM_DEBUG is not defined. It creates a new list object from an
* (objc,objv) array: that is, each of the objc elements of the array
* referenced by objv is inserted as an element into a new Tcl object.
*
* When TCL_MEM_DEBUG is defined, this function just returns the result
* of calling the debugging version Tcl_DbNewListObj.
*
* Results:
* A new list object is returned that is initialized from the object
* pointers in objv. If objc is less than or equal to zero, an empty
* object is returned. The new object's string representation is left
* NULL. The resulting new list object has ref count 0.
*
* Side effects:
* The ref counts of the elements in objv are incremented since the
* resulting list now refers to them.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewListObj
Tcl_Obj *
Tcl_NewListObj(
ListSizeT objc, /* Count of objects referenced by objv. */
Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */
{
return Tcl_DbNewListObj(objc, objv, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewListObj(
ListSizeT objc, /* Count of objects referenced by objv. */
Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */
{
ListRep listRep;
Tcl_Obj *listObj;
TclNewObj(listObj);
if (objc + 1 <= 1) {
return listObj;
}
ListRepInit(objc, objv, LISTREP_PANIC_ON_FAIL, &listRep);
ListObjReplaceRepAndInvalidate(listObj, &listRep);
return listObj;
}
#endif /* if TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_DbNewListObj --
*
* This function is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. It creates new list objects. It is the same
* as the Tcl_NewListObj function above except that it calls
* Tcl_DbCkalloc directly with the file name and line number from its
* caller. This simplifies debugging since then the [memory active]
* command will report the correct file name and line number when
* reporting objects that haven't been freed.
*
* When TCL_MEM_DEBUG is not defined, this function just returns the
* result of calling Tcl_NewListObj.
*
* Results:
* A new list object is returned that is initialized from the object
* pointers in objv. If objc is less than or equal to zero, an empty
* object is returned. The new object's string representation is left
* NULL. The new list object has ref count 0.
*
* Side effects:
* The ref counts of the elements in objv are incremented since the
* resulting list now refers to them.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewListObj(
ListSizeT objc, /* Count of objects referenced by objv. */
Tcl_Obj *const objv[], /* An array of pointers to Tcl objects. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
Tcl_Obj *listObj;
ListRep listRep;
TclDbNewObj(listObj, file, line);
if (objc + 1 <= 1) {
return listObj;
}
ListRepInit(objc, objv, LISTREP_PANIC_ON_FAIL, &listRep);
ListObjReplaceRepAndInvalidate(listObj, &listRep);
return listObj;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewListObj(
ListSizeT objc, /* Count of objects referenced by objv. */
Tcl_Obj *const objv[], /* An array of pointers to Tcl objects. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewListObj(objc, objv);
}
#endif /* TCL_MEM_DEBUG */
/*
*------------------------------------------------------------------------
*
* TclNewListObj2 --
*
* Create a new Tcl_Obj list comprising of the concatenation of two
* Tcl_Obj* arrays.
* TODO - currently this function is not used within tclListObj but
* need to see if it would be useful in other files that preallocate
* lists and then append.
*
* Results:
* Non-NULL pointer to the allocate Tcl_Obj.
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
Tcl_Obj *
TclNewListObj2(
ListSizeT objc1, /* Count of objects referenced by objv1. */
Tcl_Obj *const objv1[], /* First array of pointers to Tcl objects. */
ListSizeT objc2, /* Count of objects referenced by objv2. */
Tcl_Obj *const objv2[] /* Second array of pointers to Tcl objects. */
)
{
Tcl_Obj *listObj;
ListStore *storePtr;
ListSizeT objc = objc1 + objc2;
listObj = Tcl_NewListObj(objc, NULL);
if (objc == 0) {
return listObj; /* An empty object */
}
LIST_ASSERT_TYPE(listObj);
storePtr = ListObjStorePtr(listObj);
LIST_ASSERT(ListObjSpanPtr(listObj) == NULL);
LIST_ASSERT(storePtr->firstUsed == 0);
LIST_ASSERT(storePtr->numUsed == 0);
LIST_ASSERT(storePtr->numAllocated >= objc);
if (objc1) {
ObjArrayCopy(storePtr->slots, objc1, objv1);
}
if (objc2) {
ObjArrayCopy(&storePtr->slots[objc1], objc2, objv2);
}
storePtr->numUsed = objc;
return listObj;
}
/*
*----------------------------------------------------------------------
*
* TclListObjGetRep --
*
* This function returns a copy of the ListRep stored
* as the internal representation of an object. The reference
* counts of the (ListStore, ListSpan) contained in the representation
* are NOT incremented.
*
* Results:
* The return value is normally TCL_OK; in this case *listRepP
* is set to a copy of the descriptor stored as the internal
* representation of the Tcl_Obj containing a list. if listPtr does not
* refer to a list object and the object can not be converted to one,
* TCL_ERROR is returned and an error message will be left in the
* interpreter's result if interp is not NULL.
*
* Side effects:
* The possible conversion of the object referenced by listPtr
* to a list object. *repPtr is initialized to the internal rep
* if result is TCL_OK, or set to NULL on error.
*----------------------------------------------------------------------
*/
static int
TclListObjGetRep(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *listObj, /* List object for which an element array is
* to be returned. */
ListRep *repPtr) /* Location to store descriptor */
{
if (!TclHasInternalRep(listObj, &tclListType)) {
int result;
result = SetListFromAny(interp, listObj);
if (result != TCL_OK) {
/* Init to keep gcc happy wrt uninitialized fields at call site */
repPtr->storePtr = NULL;
repPtr->spanPtr = NULL;
return result;
}
}
ListObjGetRep(listObj, repPtr);
LISTREP_CHECK(repPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetListObj --
*
* Modify an object to be a list containing each of the objc elements of
* the object array referenced by objv.
*
* Results:
* None.
*
* Side effects:
* The object is made a list object and is initialized from the object
* pointers in objv. If objc is less than or equal to zero, an empty
* object is returned. The new object's string representation is left
* NULL. The ref counts of the elements in objv are incremented since the
* list now refers to them. The object's old string and internal
* representations are freed and its type is set NULL.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetListObj(
Tcl_Obj *objPtr, /* Object whose internal rep to init. */
ListSizeT objc, /* Count of objects referenced by objv. */
Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetListObj");
}
/*
* Set the object's type to "list" and initialize the internal rep.
* However, if there are no elements to put in the list, just give the
* object an empty string rep and a NULL type. NOTE ListRepInit must
* not be called with objc == 0!
*/
if (objc + 1 > 1) {
ListRep listRep;
/* TODO - perhaps ask for extra space? */
ListRepInit(objc, objv, LISTREP_PANIC_ON_FAIL, &listRep);
ListObjReplaceRepAndInvalidate(objPtr, &listRep);
} else {
TclFreeInternalRep(objPtr);
TclInvalidateStringRep(objPtr);
Tcl_InitStringRep(objPtr, NULL, 0);
}
}
/*
*----------------------------------------------------------------------
*
* TclListObjCopy --
*
* Makes a "pure list" copy of a list value. This provides for the C
* level a counterpart of the [lrange $list 0 end] command, while using
* internals details to be as efficient as possible.
*
* Results:
* Normally returns a pointer to a new Tcl_Obj, that contains the same
* list value as *listPtr does. The returned Tcl_Obj has a refCount of
* zero. If *listPtr does not hold a list, NULL is returned, and if
* interp is non-NULL, an error message is recorded there.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclListObjCopy(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *listObj) /* List object for which an element array is
* to be returned. */
{
Tcl_Obj *copyObj;
if (!TclHasInternalRep(listObj, &tclListType)) {
if (SetListFromAny(interp, listObj) != TCL_OK) {
return NULL;
}
}
TclNewObj(copyObj);
TclInvalidateStringRep(copyObj);
DupListInternalRep(listObj, copyObj);
return copyObj;
}
/*
*------------------------------------------------------------------------
*
* ListRepRange --
*
* Initializes a ListRep as a range within the passed ListRep.
* The range limits are clamped to the list boundaries.
*
* Results:
* None.
*
* Side effects:
* The ListStore and ListSpan referenced by in the returned ListRep
* may or may not be the same as those passed in. For example, the
* ListStore may differ because the range is small enough that a new
* ListStore is more memory-optimal. The ListSpan may differ because
* it is NULL or shared. Regardless, reference counts on the returned
* values are not incremented. Generally, ListObjReplaceRepAndInvalidate
* may be used to store the new ListRep back into an object or a
* ListRepIncrRefs followed by ListRepDecrRefs to free in case of errors.
* Any other use should be carefully reconsidered.
* TODO WARNING:- this is an awkward interface and easy for caller
* to get wrong. Mostly due to refcount combinations. Perhaps passing
* in the source listObj instead of source listRep might simplify.
*
*------------------------------------------------------------------------
*/
static void
ListRepRange(
ListRep *srcRepPtr, /* Contains source of the range */
ListSizeT rangeStart, /* Index of first element to include */
ListSizeT rangeEnd, /* Index of last element to include */
int preserveSrcRep, /* If true, srcRepPtr contents must not be
modified (generally because a shared Tcl_Obj
references it) */
ListRep *rangeRepPtr) /* Output. Must NOT be == srcRepPtr */
{
Tcl_Obj **srcElems;
ListSizeT numSrcElems = ListRepLength(srcRepPtr);
ListSizeT rangeLen;
ListSizeT numAfterRangeEnd;
LISTREP_CHECK(srcRepPtr);
/* Take the opportunity to garbage collect */
/* TODO - we probably do not need the preserveSrcRep here unlike later */
if (!preserveSrcRep) {
/* T:listrep-1.{4,5,8,9},2.{4:7},3.{15:18},4.{7,8} */
ListRepFreeUnreferenced(srcRepPtr);
} /* else T:listrep-2.{4.2,4.3,5.2,5.3,6.2,7.2,8.1} */
if (rangeStart == TCL_INDEX_NONE) {
rangeStart = 0;
}
if ((rangeEnd != TCL_INDEX_NONE) && (rangeEnd >= numSrcElems)) {
rangeEnd = numSrcElems - 1;
}
if (rangeStart + 1 > rangeEnd + 1) {
/* Empty list of capacity 1. */
ListRepInit(1, NULL, LISTREP_PANIC_ON_FAIL, rangeRepPtr);
return;
}
rangeLen = rangeEnd - rangeStart + 1;
/*
* We can create a range one of four ways:
* (0) Range encapsulates entire list
* (1) Special case: deleting in-place from end of an unshared object
* (2) Use a ListSpan referencing the current ListStore
* (3) Creating a new ListStore
* (4) Removing all elements outside the range in the current ListStore
* Option (4) may only be done if caller has not disallowed it AND
* the ListStore is not shared.
*
* The choice depends on heuristics related to speed and memory.
* TODO - heuristics below need to be measured and tuned.
*
* Note: Even if nothing below cause any changes, we still want the
* string-canonizing effect of [lrange 0 end] so the Tcl_Obj should not
* be returned as is even if the range encompasses the whole list.
*/
if (rangeStart == 0 && rangeEnd == (numSrcElems-1)) {
/* Option 0 - entire list. This may be used to canonicalize */
/* T:listrep-1.10.1,2.8.1 */
*rangeRepPtr = *srcRepPtr; /* Not ref counts not incremented */
} else if (rangeStart == 0 && (!preserveSrcRep)
&& (!ListRepIsShared(srcRepPtr) && srcRepPtr->spanPtr == NULL)) {
/* Option 1 - Special case unshared, exclude end elements, no span */
LIST_ASSERT(srcRepPtr->storePtr->firstUsed == 0); /* If no span */
ListRepElements(srcRepPtr, numSrcElems, srcElems);
numAfterRangeEnd = numSrcElems - (rangeEnd + 1);
/* Assert: Because numSrcElems > rangeEnd earlier */
if (numAfterRangeEnd != 0) {
/* T:listrep-1.{8,9} */
ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd);
}
/* srcRepPtr->storePtr->firstUsed,numAllocated unchanged */
srcRepPtr->storePtr->numUsed = rangeLen;
srcRepPtr->storePtr->flags = 0;
rangeRepPtr->storePtr = srcRepPtr->storePtr; /* Note no incr ref */
rangeRepPtr->spanPtr = NULL;
} else if (ListSpanMerited(rangeLen,
srcRepPtr->storePtr->numUsed,
srcRepPtr->storePtr->numAllocated)) {
/* Option 2 - because span would be most efficient */
ListSizeT spanStart = ListRepStart(srcRepPtr) + rangeStart;
if (!preserveSrcRep && srcRepPtr->spanPtr
&& srcRepPtr->spanPtr->refCount <= 1) {
/* If span is not shared reuse it */
/* T:listrep-2.7.3,3.{16,18} */
srcRepPtr->spanPtr->spanStart = spanStart;
srcRepPtr->spanPtr->spanLength = rangeLen;
*rangeRepPtr = *srcRepPtr;
} else {
/* Span not present or is shared. */
/* T:listrep-1.5,2.{5,7},4.{7,8} */
rangeRepPtr->storePtr = srcRepPtr->storePtr;
rangeRepPtr->spanPtr = ListSpanNew(spanStart, rangeLen);
}
/*
* We have potentially created a new internal representation that
* references the same storage as srcRep but not yet incremented its
* reference count. So do NOT call freezombies if preserveSrcRep
* is mandated.
*/
if (!preserveSrcRep) {
/* T:listrep-1.{5.1,5.2,5.4},2.{5,7},3.{16,18},4.{7,8} */
ListRepFreeUnreferenced(rangeRepPtr);
}
} else if (preserveSrcRep || ListRepIsShared(srcRepPtr)) {
/* Option 3 - span or modification in place not allowed/desired */
/* T:listrep-2.{4,6} */
ListRepElements(srcRepPtr, numSrcElems, srcElems);
/* TODO - allocate extra space? */
ListRepInit(rangeLen,
&srcElems[rangeStart],
LISTREP_PANIC_ON_FAIL,
rangeRepPtr);
} else {
/*
* Option 4 - modify in place. Note that because of the invariant
* that spanless list stores must start at 0, we have to move
* everything to the front.
* TODO - perhaps if a span already exists, no need to move to front?
* or maybe no need to move all the way to the front?
* TODO - if range is small relative to allocation, allocate new?
*/
/* Asserts follow from call to ListRepFreeUnreferenced earlier */
LIST_ASSERT(!preserveSrcRep);
LIST_ASSERT(!ListRepIsShared(srcRepPtr));
LIST_ASSERT(ListRepStart(srcRepPtr) == srcRepPtr->storePtr->firstUsed);
LIST_ASSERT(ListRepLength(srcRepPtr) == srcRepPtr->storePtr->numUsed);
ListRepElements(srcRepPtr, numSrcElems, srcElems);
/* Free leading elements outside range */
if (rangeStart != 0) {
/* T:listrep-1.4,3.15 */
ObjArrayDecrRefs(srcElems, 0, rangeStart);
}
/* Ditto for trailing */
numAfterRangeEnd = numSrcElems - (rangeEnd + 1);
/* Assert: Because numSrcElems > rangeEnd earlier */
if (numAfterRangeEnd != 0) {
/* T:listrep-3.17 */
ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd);
}
memmove(&srcRepPtr->storePtr->slots[0],
&srcRepPtr->storePtr
->slots[srcRepPtr->storePtr->firstUsed + rangeStart],
rangeLen * sizeof(Tcl_Obj *));
srcRepPtr->storePtr->firstUsed = 0;
srcRepPtr->storePtr->numUsed = rangeLen;
srcRepPtr->storePtr->flags = 0;
if (srcRepPtr->spanPtr) {
/* In case the source has a span, update it for consistency */
/* T:listrep-3.{15,17} */
srcRepPtr->spanPtr->spanStart = srcRepPtr->storePtr->firstUsed;
srcRepPtr->spanPtr->spanLength = srcRepPtr->storePtr->numUsed;
}
rangeRepPtr->storePtr = srcRepPtr->storePtr;
rangeRepPtr->spanPtr = NULL;
}
/* TODO - call freezombies here if !preserveSrcRep? */
/* Note ref counts intentionally not incremented */
LISTREP_CHECK(rangeRepPtr);
return;
}
/*
*----------------------------------------------------------------------
*
* TclListObjRange --
*
* Makes a slice of a list value.
* *listObj must be known to be a valid list.
*
* Results:
* Returns a pointer to the sliced list.
* This may be a new object or the same object if not shared.
* Returns NULL if passed listObj was not a list and could not be
* converted to one.
*
* Side effects:
* The possible conversion of the object referenced by listPtr
* to a list object.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclListObjRange(
Tcl_Obj *listObj, /* List object to take a range from. */
ListSizeT rangeStart, /* Index of first element to include. */
ListSizeT rangeEnd) /* Index of last element to include. */
{
ListRep listRep;
ListRep resultRep;
int isShared;
if (TclListObjGetRep(NULL, listObj, &listRep) != TCL_OK)
return NULL;
isShared = Tcl_IsShared(listObj);
ListRepRange(&listRep, rangeStart, rangeEnd, isShared, &resultRep);
if (isShared) {
/* T:listrep-1.10.1,2.{4.2,4.3,5.2,5.3,6.2,7.2,8.1} */
TclNewObj(listObj);
} /* T:listrep-1.{4.3,5.1,5.2} */
ListObjReplaceRepAndInvalidate(listObj, &resultRep);
return listObj;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjGetElements --
*
* This function returns an (objc,objv) array of the elements in a list
* object.
*
* Results:
* The return value is normally TCL_OK; in this case *objcPtr is set to
* the count of list elements and *objvPtr is set to a pointer to an
* array of (*objcPtr) pointers to each list element. If listPtr does not
* refer to a list object and the object can not be converted to one,
* TCL_ERROR is returned and an error message will be left in the
* interpreter's result if interp is not NULL.
*
* The objects referenced by the returned array should be treated as
* readonly and their ref counts are _not_ incremented; the caller must
* do that if it holds on to a reference. Furthermore, the pointer and
* length returned by this function may change as soon as any function is
* called on the list object; be careful about retaining the pointer in a
* local data structure.
*
* Side effects:
* The possible conversion of the object referenced by listPtr
* to a list object.
*
*----------------------------------------------------------------------
*/
#undef Tcl_ListObjGetElements
int
Tcl_ListObjGetElements(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *objPtr, /* List object for which an element array is
* to be returned. */
ListSizeT *objcPtr, /* Where to store the count of objects
* referenced by objv. */
Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of
* pointers to the list's objects. */
{
ListRep listRep;
if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK)
return TCL_ERROR;
ListRepElements(&listRep, *objcPtr, *objvPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjAppendList --
*
* This function appends the elements in the list fromObj
* to toObj. toObj must not be shared else the function will panic.
*
* Results:
* The return value is normally TCL_OK. If fromObj or toObj do not
* refer to list values, TCL_ERROR is returned and an error message is
* left in the interpreter's result if interp is not NULL.
*
* Side effects:
* The reference counts of the elements in fromObj are incremented
* since the list now refers to them. toObj and fromObj are
* converted, if necessary, to list objects. Also, appending the new
* elements may cause toObj's array of element pointers to grow.
* toObj's old string representation, if any, is invalidated.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjAppendList(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *toObj, /* List object to append elements to. */
Tcl_Obj *fromObj) /* List obj with elements to append. */
{
ListSizeT objc;
Tcl_Obj **objv;
if (Tcl_IsShared(toObj)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList");
}
if (TclListObjGetElementsM(interp, fromObj, &objc, &objv) != TCL_OK) {
return TCL_ERROR;
}
/*
* Insert the new elements starting after the lists's last element.
* Delete zero existing elements.
*/
return TclListObjAppendElements(interp, toObj, objc, objv);
}
/*
*------------------------------------------------------------------------
*
* TclListObjAppendElements --
*
* Appends multiple elements to a Tcl_Obj list object. If
* the passed Tcl_Obj is not a list object, it will be converted to one
* and an error raised if the conversion fails.
*
* The Tcl_Obj must not be shared though the internal representation
* may be.
*
* Results:
* On success, TCL_OK is returned with the specified elements appended.
* On failure, TCL_ERROR is returned with an error message in the
* interpreter if not NULL.
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
int TclListObjAppendElements (
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *toObj, /* List object to append */
ListSizeT elemCount, /* Number of elements in elemObjs[] */
Tcl_Obj * const elemObjv[]) /* Objects to append to toObj's list. */
{
ListRep listRep;
Tcl_Obj **toObjv;
ListSizeT toLen;
ListSizeT finalLen;
if (Tcl_IsShared(toObj)) {
Tcl_Panic("%s called with shared object", "TclListObjAppendElements");
}
if (TclListObjGetRep(interp, toObj, &listRep) != TCL_OK)
return TCL_ERROR; /* Cannot be converted to a list */
if (elemCount == 0)
return TCL_OK; /* Nothing to do. Note AFTER check for list above */
ListRepElements(&listRep, toLen, toObjv);
if (elemCount > LIST_MAX || toLen > (LIST_MAX - elemCount)) {
return ListLimitExceededError(interp);
}
finalLen = toLen + elemCount;
if (!ListRepIsShared(&listRep)) {
/*
* Reuse storage if possible. Even if too small, realloc-ing instead
* of creating a new ListStore will save us on manipulating Tcl_Obj
* reference counts on the elements which is a substantial cost
* if the list is not small.
*/
ListSizeT numTailFree;
ListRepFreeUnreferenced(&listRep); /* Collect garbage before checking room */
LIST_ASSERT(ListRepStart(&listRep) == listRep.storePtr->firstUsed);
LIST_ASSERT(ListRepLength(&listRep) == listRep.storePtr->numUsed);
LIST_ASSERT(toLen == listRep.storePtr->numUsed);
if (finalLen > listRep.storePtr->numAllocated) {
/* T:listrep-1.{2,11},3.6 */
ListStore *newStorePtr;
newStorePtr = ListStoreReallocate(listRep.storePtr, finalLen);
if (newStorePtr == NULL) {
return MemoryAllocationError(interp, LIST_SIZE(finalLen));
}
LIST_ASSERT(newStorePtr->numAllocated >= finalLen);
listRep.storePtr = newStorePtr;
/*
* WARNING: at this point the Tcl_Obj internal rep potentially
* points to freed storage if the reallocation returned a
* different location. Overwrite it to bring it back in sync.
*/
ListObjStompRep(toObj, &listRep);
} /* else T:listrep-3.{4,5} */
LIST_ASSERT(listRep.storePtr->numAllocated >= finalLen);
/* Current store big enough */
numTailFree = ListRepNumFreeTail(&listRep);
LIST_ASSERT((numTailFree + listRep.storePtr->firstUsed)
>= elemCount); /* Total free */
if (numTailFree < elemCount) {
/* Not enough room at back. Move some to front */
/* T:listrep-3.5 */
ListSizeT shiftCount = elemCount - numTailFree;
/* Divide remaining space between front and back */
shiftCount += (listRep.storePtr->numAllocated - finalLen) / 2;
LIST_ASSERT(shiftCount <= listRep.storePtr->firstUsed);
if (shiftCount) {
/* T:listrep-3.5 */
ListRepUnsharedShiftDown(&listRep, shiftCount);
}
} /* else T:listrep-3.{4,6} */
ObjArrayCopy(&listRep.storePtr->slots[ListRepStart(&listRep)
+ ListRepLength(&listRep)],
elemCount,
elemObjv);
listRep.storePtr->numUsed = finalLen;
if (listRep.spanPtr) {
/* T:listrep-3.{4,5,6} */
LIST_ASSERT(listRep.spanPtr->spanStart
== listRep.storePtr->firstUsed);
listRep.spanPtr->spanLength = finalLen;
} /* else T:listrep-3.6.3 */
LIST_ASSERT(ListRepStart(&listRep) == listRep.storePtr->firstUsed);
LIST_ASSERT(ListRepLength(&listRep) == finalLen);
LISTREP_CHECK(&listRep);
ListObjReplaceRepAndInvalidate(toObj, &listRep);
return TCL_OK;
}
/*
* Have to make a new list rep, either shared or no room in old one.
* If the old list did not have a span (all elements at front), do
* not leave space in the front either, assuming all appends and no
* prepends.
*/
if (ListRepInit(finalLen,
NULL,
listRep.spanPtr ? LISTREP_SPACE_FAVOR_BACK
: LISTREP_SPACE_ONLY_BACK,
&listRep)
!= TCL_OK) {
return TCL_ERROR;
}
LIST_ASSERT(listRep.storePtr->numAllocated >= finalLen);
if (toLen) {
/* T:listrep-2.{2,9},4.5 */
ObjArrayCopy(ListRepSlotPtr(&listRep, 0), toLen, toObjv);
}
ObjArrayCopy(ListRepSlotPtr(&listRep, toLen), elemCount, elemObjv);
listRep.storePtr->numUsed = finalLen;
if (listRep.spanPtr) {
/* T:listrep-4.5 */
LIST_ASSERT(listRep.spanPtr->spanStart == listRep.storePtr->firstUsed);
listRep.spanPtr->spanLength = finalLen;
}
LISTREP_CHECK(&listRep);
ListObjReplaceRepAndInvalidate(toObj, &listRep);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjAppendElement --
*
* This function is a special purpose version of Tcl_ListObjAppendList:
* it appends a single object referenced by elemObj to the list object
* referenced by toObj. If toObj is not already a list object, an
* attempt will be made to convert it to one.
*
* Results:
* The return value is normally TCL_OK; in this case elemObj is added to
* the end of toObj's list. If toObj does not refer to a list object
* and the object can not be converted to one, TCL_ERROR is returned and
* an error message will be left in the interpreter's result if interp is
* not NULL.
*
* Side effects:
* The ref count of elemObj is incremented since the list now refers to
* it. toObj will be converted, if necessary, to a list object. Also,
* appending the new element may cause listObj's array of element
* pointers to grow. toObj's old string representation, if any, is
* invalidated.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjAppendElement(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *toObj, /* List object to append elemObj to. */
Tcl_Obj *elemObj) /* Object to append to toObj's list. */
{
/*
* TODO - compare perf with 8.6 to see if worth optimizing single
* element case
*/
return TclListObjAppendElements(interp, toObj, 1, &elemObj);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjIndex --
*
* This function returns a pointer to the index'th object from the list
* referenced by listPtr. The first element has index 0. If index is
* negative or greater than or equal to the number of elements in the
* list, a NULL is returned. If listPtr is not a list object, an attempt
* will be made to convert it to a list.
*
* Results:
* The return value is normally TCL_OK; in this case objPtrPtr is set to
* the Tcl_Obj pointer for the index'th list element or NULL if index is
* out of range. This object should be treated as readonly and its ref
* count is _not_ incremented; the caller must do that if it holds on to
* the reference. If listPtr does not refer to a list and can't be
* converted to one, TCL_ERROR is returned and an error message is left
* in the interpreter's result if interp is not NULL.
*
* Side effects:
* listPtr will be converted, if necessary, to a list object.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjIndex(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *listObj, /* List object to index into. */
ListSizeT index, /* Index of element to return. */
Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */
{
Tcl_Obj **elemObjs;
ListSizeT numElems;
/*
* TODO
* Unlike the original list code, this does not optimize for lindex'ing
* an empty string when the internal rep is not already a list. On the
* other hand, this code will be faster for the case where the object
* is currently a dict. Benchmark the two cases.
*/
if (TclListObjGetElementsM(interp, listObj, &numElems, &elemObjs)
!= TCL_OK) {
return TCL_ERROR;
}
if (index >= numElems) {
*objPtrPtr = NULL;
} else {
*objPtrPtr = elemObjs[index];
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjLength --
*
* This function returns the number of elements in a list object. If the
* object is not already a list object, an attempt will be made to
* convert it to one.
*
* Results:
* The return value is normally TCL_OK; in this case *intPtr will be set
* to the integer count of list elements. If listPtr does not refer to a
* list object and the object can not be converted to one, TCL_ERROR is
* returned and an error message will be left in the interpreter's result
* if interp is not NULL.
*
* Side effects:
* The possible conversion of the argument object to a list object.
*
*----------------------------------------------------------------------
*/
#undef Tcl_ListObjLength
int
Tcl_ListObjLength(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *listObj, /* List object whose #elements to return. */
ListSizeT *lenPtr) /* The resulting int is stored here. */
{
ListRep listRep;
/*
* TODO
* Unlike the original list code, this does not optimize for lindex'ing
* an empty string when the internal rep is not already a list. On the
* other hand, this code will be faster for the case where the object
* is currently a dict. Benchmark the two cases.
*/
if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
return TCL_ERROR;
}
*lenPtr = ListRepLength(&listRep);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjReplace --
*
* This function replaces zero or more elements of the list referenced by
* listObj with the objects from an (objc,objv) array. The objc elements
* of the array referenced by objv replace the count elements in listPtr
* starting at first.
*
* If the argument first is zero or negative, it refers to the first
* element. If first is greater than or equal to the number of elements
* in the list, then no elements are deleted; the new elements are
* appended to the list. Count gives the number of elements to replace.
* If count is zero or negative then no elements are deleted; the new
* elements are simply inserted before first.
*
* The argument objv refers to an array of objc pointers to the new
* elements to be added to listPtr in place of those that were deleted.
* If objv is NULL, no new elements are added. If listPtr is not a list
* object, an attempt will be made to convert it to one.
*
* Results:
* The return value is normally TCL_OK. If listPtr does not refer to a
* list object and can not be converted to one, TCL_ERROR is returned and
* an error message will be left in the interpreter's result if interp is
* not NULL.
*
* Side effects:
* The ref counts of the objc elements in objv are incremented since the
* resulting list now refers to them. Similarly, the ref counts for
* replaced objects are decremented. listObj is converted, if necessary,
* to a list object. listObj's old string representation, if any, is
* freed.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjReplace(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *listObj, /* List object whose elements to replace. */
ListSizeT first, /* Index of first element to replace. */
ListSizeT numToDelete, /* Number of elements to replace. */
ListSizeT numToInsert, /* Number of objects to insert. */
Tcl_Obj *const insertObjs[])/* Tcl objects to insert */
{
ListRep listRep;
ListSizeT origListLen;
ptrdiff_t lenChange;
ptrdiff_t leadSegmentLen;
ptrdiff_t tailSegmentLen;
ListSizeT numFreeSlots;
ptrdiff_t leadShift;
ptrdiff_t tailShift;
Tcl_Obj **listObjs;
int favor;
if (Tcl_IsShared(listObj)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
}
if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK)
return TCL_ERROR; /* Cannot be converted to a list */
/* TODO - will need modification if Tcl9 sticks to unsigned indices */
/* Make limits sane */
origListLen = ListRepLength(&listRep);
if (first == TCL_INDEX_NONE) {
first = 0;
}
if (first > origListLen) {
first = origListLen; /* So we'll insert after last element. */
}
if (numToDelete == TCL_INDEX_NONE) {
numToDelete = 0;
} else if (first > ListSizeT_MAX - numToDelete /* Handle integer overflow */
|| origListLen < first + numToDelete) {
numToDelete = origListLen - first;
}
if (numToInsert > ListSizeT_MAX - (origListLen - numToDelete)) {
return ListLimitExceededError(interp);
}
if ((first+numToDelete) >= origListLen) {
/* Operating at back of list. Favor leaving space at back */
favor = LISTREP_SPACE_FAVOR_BACK;
} else if (first == 0) {
/* Operating on front of list. Favor leaving space in front */
favor = LISTREP_SPACE_FAVOR_FRONT;
} else {
/* Operating on middle of list. */
favor = LISTREP_SPACE_FAVOR_NONE;
}
/*
* There are a number of special cases to consider from an optimization
* point of view.
* (1) Pure deletes (numToInsert==0) from the front or back can be treated
* as a range op irrespective of whether the ListStore is shared or not
* (2) Pure inserts (numToDelete == 0)
* (2a) Pure inserts at the back can be treated as appends
* (2b) Pure inserts from the *front* can be optimized under certain
* conditions by inserting before first ListStore slot in use if there
* is room, again irrespective of sharing
* (3) If the ListStore is shared OR there is insufficient free space
* OR existing allocation is too large compared to new size, create
* a new ListStore
* (4) Unshared ListStore with sufficient free space. Delete, shift and
* insert within the ListStore.
*/
/* Note: do not do TclInvalidateStringRep as yet in case there are errors */
/* Check Case (1) - Treat pure deletes from front or back as range ops */
if (numToInsert == 0) {
if (numToDelete == 0) {
/*
* Should force canonical even for no-op. Remember Tcl_Obj unshared
* so OK to invalidate string rep
*/
/* T:listrep-1.10,2.8 */
TclInvalidateStringRep(listObj);
return TCL_OK;
}
if (first == 0) {
/* Delete from front, so return tail. */
/* T:listrep-1.{4,5},2.{4,5},3.{15,16},4.7 */
ListRep tailRep;
ListRepRange(&listRep, numToDelete, origListLen-1, 0, &tailRep);
ListObjReplaceRepAndInvalidate(listObj, &tailRep);
return TCL_OK;
} else if ((first+numToDelete) >= origListLen) {
/* Delete from tail, so return head */
/* T:listrep-1.{8,9},2.{6,7},3.{17,18},4.8 */
ListRep headRep;
ListRepRange(&listRep, 0, first-1, 0, &headRep);
ListObjReplaceRepAndInvalidate(listObj, &headRep);
return TCL_OK;
}
/* Deletion from middle. Fall through to general case */
}
/* Garbage collect before checking the pure insert optimization */
ListRepFreeUnreferenced(&listRep);
/*
* Check Case (2) - pure inserts under certain conditions:
*/
if (numToDelete == 0) {
/* Case (2a) - Append to list. */
if (first == origListLen) {
/* T:listrep-1.11,2.9,3.{5,6},2.2.1 */
return TclListObjAppendElements(
interp, listObj, numToInsert, insertObjs);
}
/*
* Case (2b) - pure inserts at front under some circumstances
* (i) Insertion must be at head of list
* (ii) The list's span must be at head of the in-use slots in the store
* (iii) There must be unused room at front of the store
* NOTE THIS IS TRUE EVEN IF THE ListStore IS SHARED as it will not
* affect the other Tcl_Obj's referencing this ListStore.
*/
if (first == 0 && /* (i) */
ListRepStart(&listRep) == listRep.storePtr->firstUsed && /* (ii) */
numToInsert <= listRep.storePtr->firstUsed /* (iii) */
) {
ListSizeT newLen;
LIST_ASSERT(numToInsert); /* Else would have returned above */
listRep.storePtr->firstUsed -= numToInsert;
ObjArrayCopy(&listRep.storePtr->slots[listRep.storePtr->firstUsed],
numToInsert,
insertObjs);
listRep.storePtr->numUsed += numToInsert;
newLen = listRep.spanPtr->spanLength + numToInsert;
if (listRep.spanPtr && listRep.spanPtr->refCount <= 1) {
/* An unshared span record, re-use it */
/* T:listrep-3.1 */
listRep.spanPtr->spanStart = listRep.storePtr->firstUsed;
listRep.spanPtr->spanLength = newLen;
} else {
/* Need a new span record */
if (listRep.storePtr->firstUsed == 0) {
listRep.spanPtr = NULL;
} else {
/* T:listrep-4.3 */
listRep.spanPtr =
ListSpanNew(listRep.storePtr->firstUsed, newLen);
}
}
ListObjReplaceRepAndInvalidate(listObj, &listRep);
return TCL_OK;
}
}
/* Just for readability of the code */
lenChange = numToInsert - numToDelete;
leadSegmentLen = first;
tailSegmentLen = origListLen - (first + numToDelete);
numFreeSlots = listRep.storePtr->numAllocated - listRep.storePtr->numUsed;
/*
* Before further processing, if unshared, try and reallocate to avoid
* new allocation below. This avoids expensive ref count manipulation
* later by not having to go through the ListRepInit and
* ListObjReplaceAndInvalidate below.
* TODO - we could be smarter about the reallocate. Use of realloc
* means all new free space is at the back. Instead, the realloc could
* be an explicit alloc and memmove which would let us redistribute
* free space.
*/
if ((ptrdiff_t)numFreeSlots < lenChange && !ListRepIsShared(&listRep)) {
/* T:listrep-1.{1,3,14,18,21},3.{3,10,11,14,27,32,41} */
ListStore *newStorePtr =
ListStoreReallocate(listRep.storePtr, origListLen + lenChange);
if (newStorePtr == NULL) {
return MemoryAllocationError(interp,
LIST_SIZE(origListLen + lenChange));
}
listRep.storePtr = newStorePtr;
numFreeSlots =
listRep.storePtr->numAllocated - listRep.storePtr->numUsed;
/*
* WARNING: at this point the Tcl_Obj internal rep potentially
* points to freed storage if the reallocation returned a
* different location. Overwrite it to bring it back in sync.
*/
ListObjStompRep(listObj, &listRep);
}
/*
* Case (3) a new ListStore is required
* (a) The passed-in ListStore is shared
* (b) There is not enough free space in the unshared passed-in ListStore
* (c) The new unshared size is much "smaller" (TODO) than the allocated space
* TODO - for unshared case ONLY, consider a "move" based implementation
*/
if (ListRepIsShared(&listRep) || /* 3a */
(ptrdiff_t)numFreeSlots < lenChange || /* 3b */
(origListLen + lenChange) < (listRep.storePtr->numAllocated / 4) /* 3c */
) {
ListRep newRep;
Tcl_Obj **toObjs;
listObjs = &listRep.storePtr->slots[ListRepStart(&listRep)];
ListRepInit(origListLen + lenChange,
NULL,
LISTREP_PANIC_ON_FAIL | favor,
&newRep);
toObjs = ListRepSlotPtr(&newRep, 0);
if (leadSegmentLen > 0) {
/* T:listrep-2.{2,3,13:18},4.{6,9,13:18} */
ObjArrayCopy(toObjs, leadSegmentLen, listObjs);
}
if (numToInsert > 0) {
/* T:listrep-2.{1,2,3,10:18},4.{1,2,4,6,10:18} */
ObjArrayCopy(&toObjs[leadSegmentLen],
numToInsert,
insertObjs);
}
if (tailSegmentLen > 0) {
/* T:listrep-2.{1,2,3,10:15},4.{1,2,4,6,9:12,16:18} */
ObjArrayCopy(&toObjs[leadSegmentLen + numToInsert],
tailSegmentLen,
&listObjs[leadSegmentLen+numToDelete]);
}
newRep.storePtr->numUsed = origListLen + lenChange;
if (newRep.spanPtr) {
/* T:listrep-2.{1,2,3,10:18},4.{1,2,4,6,9:18} */
newRep.spanPtr->spanLength = newRep.storePtr->numUsed;
}
LISTREP_CHECK(&newRep);
ListObjReplaceRepAndInvalidate(listObj, &newRep);
return TCL_OK;
}
/*
* Case (4) - unshared ListStore with sufficient room.
* After deleting elements, there will be a corresponding gap. If this
* gap does not match number of insertions, either the lead segment,
* or the tail segment, or both will have to be moved.
* The general strategy is to move the fewest number of elements. If
*
* TODO - what about appends to unshared ? Is below sufficiently optimal?
*/
/* Following must hold for unshared listreps after ListRepFreeUnreferenced above */
LIST_ASSERT(origListLen == listRep.storePtr->numUsed);
LIST_ASSERT(origListLen == ListRepLength(&listRep));
LIST_ASSERT(ListRepStart(&listRep) == listRep.storePtr->firstUsed);
LIST_ASSERT((numToDelete + numToInsert) > 0);
/* Base of slot array holding the list elements */
listObjs = &listRep.storePtr->slots[ListRepStart(&listRep)];
/*
* Free up elements to be deleted. Before that, increment the ref counts
* for objects to be inserted in case there is overlap. T:listobj-11.1
*/
if (numToInsert) {
/* T:listrep-1.{1,3,12:21},3.{2,3,7:14,23:41} */
ObjArrayIncrRefs(insertObjs, 0, numToInsert);
}
if (numToDelete) {
/* T:listrep-1.{6,7,12:21},3.{19:41} */
ObjArrayDecrRefs(listObjs, first, numToDelete);
}
/*
* TODO - below the moves are optimized but this may result in needing a
* span allocation. Perhaps for small lists, it may be more efficient to
* just move everything up front and save on allocating a span.
*/
/*
* Calculate shifts if necessary to accomodate insertions.
* NOTE: all indices are relative to listObjs which is not necessarily the
* start of the ListStore storage area.
*
* leadShift - how much to shift the lead segment
* tailShift - how much to shift the tail segment
* insertTarget - index where to insert.
*/
if (lenChange == 0) {
/* T:listrep-1.{12,15,19},3.{23,28,33}. Exact fit */
leadShift = 0;
tailShift = 0;
} else if (lenChange < 0) {
/*
* More deletions than insertions. The gap after deletions is large
* enough for insertions. Move a segment depending on size.
*/
if (leadSegmentLen > tailSegmentLen) {
/* Tail segment smaller. Insert after lead, move tail down */
/* T:listrep-1.{7,17,20},3.{21,2229,35} */
leadShift = 0;
tailShift = lenChange;
} else {
/* Lead segment smaller. Insert before tail, move lead up */
/* T:listrep-1.{6,13,16},3.{19,20,24,34} */
leadShift = -lenChange;
tailShift = 0;
}
} else {
LIST_ASSERT(lenChange > 0); /* Reminder */
/*
* We need to make room for the insertions. Again we have multiple
* possibilities. We may be able to get by just shifting one segment
* or need to shift both. In the former case, favor shifting the
* smaller segment.
*/
ptrdiff_t leadSpace = ListRepNumFreeHead(&listRep);
ptrdiff_t tailSpace = ListRepNumFreeTail(&listRep);
ptrdiff_t finalFreeSpace = leadSpace + tailSpace - lenChange;
LIST_ASSERT((leadSpace + tailSpace) >= lenChange);
if (leadSpace >= lenChange
&& (leadSegmentLen < tailSegmentLen || tailSpace < lenChange)) {
/* Move only lead to the front to make more room */
/* T:listrep-3.25,36,38, */
leadShift = -lenChange;
tailShift = 0;
/*
* Redistribute the remaining free space between the front and
* back if either there is no tail space left or if the
* entire list is the head anyways. This is an important
* optimization for further operations like further asymmetric
* insertions.
*/
if (finalFreeSpace > 1 && (tailSpace == 0 || tailSegmentLen == 0)) {
ptrdiff_t postShiftLeadSpace = leadSpace - lenChange;
if (postShiftLeadSpace > (finalFreeSpace/2)) {
ListSizeT extraShift = postShiftLeadSpace - (finalFreeSpace / 2);
leadShift -= extraShift;
tailShift = -extraShift; /* Move tail to the front as well */
}
} /* else T:listrep-3.{7,12,25,38} */
LIST_ASSERT(leadShift >= 0 || leadSpace >= -leadShift);
} else if (tailSpace >= lenChange) {
/* Move only tail segment to the back to make more room. */
/* T:listrep-3.{8,10,11,14,26,27,30,32,37,39,41} */
leadShift = 0;
tailShift = lenChange;
/*
* See comments above. This is analogous.
*/
if (finalFreeSpace > 1 && (leadSpace == 0 || leadSegmentLen == 0)) {
ptrdiff_t postShiftTailSpace = tailSpace - lenChange;
if (postShiftTailSpace > (finalFreeSpace/2)) {
/* T:listrep-1.{1,3,14,18,21},3.{2,3,26,27} */
ListSizeT extraShift = postShiftTailSpace - (finalFreeSpace / 2);
tailShift += extraShift;
leadShift = extraShift; /* Move head to the back as well */
}
}
LIST_ASSERT(tailShift <= tailSpace);
} else {
/*
* Both lead and tail need to be shifted to make room.
* Divide remaining free space equally between front and back.
*/
/* T:listrep-3.{9,13,31,40} */
LIST_ASSERT(leadSpace < lenChange);
LIST_ASSERT(tailSpace < lenChange);
/*
* leadShift = leadSpace - (finalFreeSpace/2)
* Thus leadShift <= leadSpace
* Also,
* = leadSpace - (leadSpace + tailSpace - lenChange)/2
* = leadSpace/2 - tailSpace/2 + lenChange/2
* >= 0 because lenChange > tailSpace
*/
leadShift = leadSpace - (finalFreeSpace / 2);
tailShift = lenChange - leadShift;
if (tailShift > tailSpace) {
/* Account for integer division errors */
leadShift += 1;
tailShift -= 1;
}
/*
* Following must be true because otherwise one of the previous
* if clauses would have been taken.
*/
LIST_ASSERT(leadShift > 0 && leadShift < lenChange);
LIST_ASSERT(tailShift > 0 && tailShift < lenChange);
leadShift = -leadShift; /* Lead is actually shifted downward */
}
}
/* Careful about order of moves! */
if (leadShift > 0) {
/* Will happen when we have to make room at bottom */
if (tailShift != 0 && tailSegmentLen != 0) {
/* T:listrep-1.{1,3,14,18},3.{2,3,26,27} */
ListSizeT tailStart = leadSegmentLen + numToDelete;
memmove(&listObjs[tailStart + tailShift],
&listObjs[tailStart],
tailSegmentLen * sizeof(Tcl_Obj *));
}
if (leadSegmentLen != 0) {
/* T:listrep-1.{3,6,16,18,21},3.{19,20,34} */
memmove(&listObjs[leadShift],
&listObjs[0],
leadSegmentLen * sizeof(Tcl_Obj *));
}
} else {
if (leadShift != 0 && leadSegmentLen != 0) {
/* T:listrep-3.{7,9,12,13,31,36,38,40} */
memmove(&listObjs[leadShift],
&listObjs[0],
leadSegmentLen * sizeof(Tcl_Obj *));
}
if (tailShift != 0 && tailSegmentLen != 0) {
/* T:listrep-1.{7,17},3.{8:11,13,14,21,22,35,37,39:41} */
ListSizeT tailStart = leadSegmentLen + numToDelete;
memmove(&listObjs[tailStart + tailShift],
&listObjs[tailStart],
tailSegmentLen * sizeof(Tcl_Obj *));
}
}
if (numToInsert) {
/* Do NOT use ObjArrayCopy here since we have already incr'ed ref counts */
/* T:listrep-1.{1,3,12:21},3.{2,3,7:14,23:41} */
memmove(&listObjs[leadSegmentLen + leadShift],
insertObjs,
numToInsert * sizeof(Tcl_Obj *));
}
listRep.storePtr->firstUsed += leadShift;
listRep.storePtr->numUsed = origListLen + lenChange;
listRep.storePtr->flags = 0;
if (listRep.spanPtr && listRep.spanPtr->refCount <= 1) {
/* An unshared span record, re-use it, even if not required */
/* T:listrep-3.{2,3,7:14},3.{19:41} */
listRep.spanPtr->spanStart = listRep.storePtr->firstUsed;
listRep.spanPtr->spanLength = listRep.storePtr->numUsed;
} else {
/* Need a new span record */
if (listRep.storePtr->firstUsed == 0) {
/* T:listrep-1.{7,12,15,17,19,20} */
listRep.spanPtr = NULL;
} else {
/* T:listrep-1.{1,3,6.1,13,14,16,18,21} */
listRep.spanPtr = ListSpanNew(listRep.storePtr->firstUsed,
listRep.storePtr->numUsed);
}
}
LISTREP_CHECK(&listRep);
ListObjReplaceRepAndInvalidate(listObj, &listRep);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclLindexList --
*
* This procedure handles the 'lindex' command when objc==3.
*
* Results:
* Returns a pointer to the object extracted, or NULL if an error
* occurred. The returned object already includes one reference count for
* the pointer returned.
*
* Side effects:
* None.
*
* Notes:
* This procedure is implemented entirely as a wrapper around
* TclLindexFlat. All it does is reconfigure the argument format into the
* form required by TclLindexFlat, while taking care to manage shimmering
* in such a way that we tend to keep the most useful internalreps and/or
* avoid the most expensive conversions.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclLindexList(
Tcl_Interp *interp, /* Tcl interpreter. */
Tcl_Obj *listObj, /* List being unpacked. */
Tcl_Obj *argObj) /* Index or index list. */
{
ListSizeT index; /* Index into the list. */
Tcl_Obj *indexListCopy;
Tcl_Obj **indexObjs;
ListSizeT numIndexObjs;
/*
* Determine whether argPtr designates a list or a single index. We have
* to be careful about the order of the checks to avoid repeated
* shimmering; if internal rep is already a list do not shimmer it.
* see TIP#22 and TIP#33 for the details.
*/
if (!TclHasInternalRep(argObj, &tclListType)
&& TclGetIntForIndexM(NULL, argObj, ListSizeT_MAX - 1, &index)
== TCL_OK) {
/*
* argPtr designates a single index.
*/
return TclLindexFlat(interp, listObj, 1, &argObj);
}
/*
* Here we make a private copy of the index list argument to avoid any
* shimmering issues that might invalidate the indices array below while
* we are still using it. This is probably unnecessary. It does not appear
* that any damaging shimmering is possible, and no test has been devised
* to show any error when this private copy is not made. But it's cheap,
* and it offers some future-proofing insurance in case the TclLindexFlat
* implementation changes in some unexpected way, or some new form of
* trace or callback permits things to happen that the current
* implementation does not.
*/
indexListCopy = TclListObjCopy(NULL, argObj);
if (indexListCopy == NULL) {
/*
* The argument is neither an index nor a well-formed list.
* Report the error via TclLindexFlat.
* TODO - This is as original. why not directly return an error?
*/
return TclLindexFlat(interp, listObj, 1, &argObj);
}
ListObjGetElements(indexListCopy, numIndexObjs, indexObjs);
listObj = TclLindexFlat(interp, listObj, numIndexObjs, indexObjs);
Tcl_DecrRefCount(indexListCopy);
return listObj;
}
/*
*----------------------------------------------------------------------
*
* TclLindexFlat --
*
* This procedure is the core of the 'lindex' command, with all index
* arguments presented as a flat list.
*
* Results:
* Returns a pointer to the object extracted, or NULL if an error
* occurred. The returned object already includes one reference count for
* the pointer returned.
*
* Side effects:
* None.
*
* Notes:
* The reference count of the returned object includes one reference
* corresponding to the pointer returned. Thus, the calling code will
* usually do something like:
* Tcl_SetObjResult(interp, result);
* Tcl_DecrRefCount(result);
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclLindexFlat(
Tcl_Interp *interp, /* Tcl interpreter. */
Tcl_Obj *listObj, /* Tcl object representing the list. */
ListSizeT indexCount, /* Count of indices. */
Tcl_Obj *const indexArray[])/* Array of pointers to Tcl objects that
* represent the indices in the list. */
{
ListSizeT i;
Tcl_IncrRefCount(listObj);
for (i=0 ; i<indexCount && listObj ; i++) {
ListSizeT index, listLen = 0;
Tcl_Obj **elemPtrs = NULL, *sublistCopy;
/*
* Here we make a private copy of the current sublist, so we avoid any
* shimmering issues that might invalidate the elemPtr array below
* while we are still using it. See test lindex-8.4.
*/
sublistCopy = TclListObjCopy(interp, listObj);
Tcl_DecrRefCount(listObj);
listObj = NULL;
if (sublistCopy == NULL) {
/* The sublist is not a list at all => error. */
break;
}
LIST_ASSERT_TYPE(sublistCopy);
ListObjGetElements(sublistCopy, listLen, elemPtrs);
if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1,
&index) == TCL_OK) {
if (index >= listLen) {
/*
* Index is out of range. Break out of loop with empty result.
* First check remaining indices for validity
*/
while (++i < indexCount) {
if (TclGetIntForIndexM(
interp, indexArray[i], ListSizeT_MAX - 1, &index)
!= TCL_OK) {
Tcl_DecrRefCount(sublistCopy);
return NULL;
}
}
TclNewObj(listObj);
} else {
/* Extract the pointer to the appropriate element. */
listObj = elemPtrs[index];
}
Tcl_IncrRefCount(listObj);
}
Tcl_DecrRefCount(sublistCopy);
}
return listObj;
}
/*
*----------------------------------------------------------------------
*
* TclLsetList --
*
* Core of the 'lset' command when objc == 4. Objv[2] may be either a
* scalar index or a list of indices.
* It also handles 'lpop' when given a NULL value.
*
* Results:
* Returns the new value of the list variable, or NULL if there was an
* error. The returned object includes one reference count for the
* pointer returned.
*
* Side effects:
* None.
*
* Notes:
* This procedure is implemented entirely as a wrapper around
* TclLsetFlat. All it does is reconfigure the argument format into the
* form required by TclLsetFlat, while taking care to manage shimmering
* in such a way that we tend to keep the most useful internalreps and/or
* avoid the most expensive conversions.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclLsetList(
Tcl_Interp *interp, /* Tcl interpreter. */
Tcl_Obj *listObj, /* Pointer to the list being modified. */
Tcl_Obj *indexArgObj, /* Index or index-list arg to 'lset'. */
Tcl_Obj *valueObj) /* Value arg to 'lset' or NULL to 'lpop'. */
{
ListSizeT indexCount = 0; /* Number of indices in the index list. */
Tcl_Obj **indices = NULL; /* Vector of indices in the index list. */
Tcl_Obj *retValueObj; /* Pointer to the list to be returned. */
ListSizeT index; /* Current index in the list - discarded. */
Tcl_Obj *indexListCopy;
/*
* Determine whether the index arg designates a list or a single index.
* We have to be careful about the order of the checks to avoid repeated
* shimmering; see TIP #22 and #23 for details.
*/
if (!TclHasInternalRep(indexArgObj, &tclListType)
&& TclGetIntForIndexM(NULL, indexArgObj, ListSizeT_MAX - 1, &index)
== TCL_OK) {
/* indexArgPtr designates a single index. */
/* T:listrep-1.{2.1,12.1,15.1,19.1},2.{2.3,9.3,10.1,13.1,16.1}, 3.{4,5,6}.3 */
return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
}
indexListCopy = TclListObjCopy(NULL, indexArgObj);
if (indexListCopy == NULL) {
/*
* indexArgPtr designates something that is neither an index nor a
* well formed list. Report the error via TclLsetFlat.
*/
return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
}
LIST_ASSERT_TYPE(indexListCopy);
ListObjGetElements(indexListCopy, indexCount, indices);
/*
* Let TclLsetFlat handle the actual lset'ting.
*/
retValueObj = TclLsetFlat(interp, listObj, indexCount, indices, valueObj);
Tcl_DecrRefCount(indexListCopy);
return retValueObj;
}
/*
*----------------------------------------------------------------------
*
* TclLsetFlat --
*
* Core engine of the 'lset' command.
* It also handles 'lpop' when given a NULL value.
*
* Results:
* Returns the new value of the list variable, or NULL if an error
* occurred. The returned object includes one reference count for the
* pointer returned.
*
* Side effects:
* On entry, the reference count of the variable value does not reflect
* any references held on the stack. The first action of this function is
* to determine whether the object is shared, and to duplicate it if it
* is. The reference count of the duplicate is incremented. At this
* point, the reference count will be 1 for either case, so that the
* object will appear to be unshared.
*
* If an error occurs, and the object has been duplicated, the reference
* count on the duplicate is decremented so that it is now 0: this
* dismisses any memory that was allocated by this function.
*
* If no error occurs, the reference count of the original object is
* incremented if the object has not been duplicated, and nothing is done
* to a reference count of the duplicate. Now the reference count of an
* unduplicated object is 2 (the returned pointer, plus the one stored in
* the variable). The reference count of a duplicate object is 1,
* reflecting that the returned pointer is the only active reference. The
* caller is expected to store the returned value back in the variable
* and decrement its reference count. (INST_STORE_* does exactly this.)
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclLsetFlat(
Tcl_Interp *interp, /* Tcl interpreter. */
Tcl_Obj *listObj, /* Pointer to the list being modified. */
ListSizeT indexCount, /* Number of index args. */
Tcl_Obj *const indexArray[],
/* Index args. */
Tcl_Obj *valueObj) /* Value arg to 'lset' or NULL to 'lpop'. */
{
ListSizeT index, len;
int result;
Tcl_Obj *subListObj, *retValueObj;
Tcl_Obj *pendingInvalidates[10];
Tcl_Obj **pendingInvalidatesPtr = pendingInvalidates;
ListSizeT numPendingInvalidates = 0;
/*
* If there are no indices, simply return the new value. (Without
* indices, [lset] is a synonym for [set].
* [lpop] does not use this but protect for NULL valueObj just in case.
*/
if (indexCount == 0) {
if (valueObj != NULL) {
Tcl_IncrRefCount(valueObj);
}
return valueObj;
}
/*
* If the list is shared, make a copy we can modify (copy-on-write). We
* use Tcl_DuplicateObj() instead of TclListObjCopy() for a few reasons:
* 1) we have not yet confirmed listObj is actually a list; 2) We make a
* verbatim copy of any existing string rep, and when we combine that with
* the delayed invalidation of string reps of modified Tcl_Obj's
* implemented below, the outcome is that any error condition that causes
* this routine to return NULL, will leave the string rep of listObj and
* all elements to be unchanged.
*/
subListObj = Tcl_IsShared(listObj) ? Tcl_DuplicateObj(listObj) : listObj;
/*
* Anchor the linked list of Tcl_Obj's whose string reps must be
* invalidated if the operation succeeds.
*/
retValueObj = subListObj;
result = TCL_OK;
/* Allocate if static array for pending invalidations is too small */
if (indexCount
> (int) (sizeof(pendingInvalidates) / sizeof(pendingInvalidates[0]))) {
pendingInvalidatesPtr =
(Tcl_Obj **) Tcl_Alloc(indexCount * sizeof(*pendingInvalidatesPtr));
}
/*
* Loop through all the index arguments, and for each one dive into the
* appropriate sublist.
*/
do {
ListSizeT elemCount;
Tcl_Obj *parentList, **elemPtrs;
/*
* Check for the possible error conditions...
*/
if (TclListObjGetElementsM(interp, subListObj, &elemCount, &elemPtrs)
!= TCL_OK) {
/* ...the sublist we're indexing into isn't a list at all. */
result = TCL_ERROR;
break;
}
/*
* WARNING: the macro TclGetIntForIndexM is not safe for
* post-increments, avoid '*indexArray++' here.
*/
if (TclGetIntForIndexM(interp, *indexArray, elemCount - 1, &index)
!= TCL_OK) {
/* ...the index we're trying to use isn't an index at all. */
result = TCL_ERROR;
indexArray++; /* Why bother with this increment? TBD */
break;
}
indexArray++;
if (index > elemCount
|| (valueObj == NULL && index >= elemCount)) {
/* ...the index points outside the sublist. */
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("index \"%s\" out of range",
Tcl_GetString(indexArray[-1])));
Tcl_SetErrorCode(interp,
"TCL",
"VALUE",
"INDEX"
"OUTOFRANGE",
NULL);
}
result = TCL_ERROR;
break;
}
/*
* No error conditions. As long as we're not yet on the last index,
* determine the next sublist for the next pass through the loop,
* and take steps to make sure it is an unshared copy, as we intend
* to modify it.
*/
if (--indexCount) {
parentList = subListObj;
if (index == elemCount) {
TclNewObj(subListObj);
} else {
subListObj = elemPtrs[index];
}
if (Tcl_IsShared(subListObj)) {
subListObj = Tcl_DuplicateObj(subListObj);
}
/*
* Replace the original elemPtr[index] in parentList with a copy
* we know to be unshared. This call will also deal with the
* situation where parentList shares its internalrep with other
* Tcl_Obj's. Dealing with the shared internalrep case can
* cause subListObj to become shared again, so detect that case
* and make and store another copy.
*/
if (index == elemCount) {
Tcl_ListObjAppendElement(NULL, parentList, subListObj);
} else {
TclListObjSetElement(NULL, parentList, index, subListObj);
}
if (Tcl_IsShared(subListObj)) {
subListObj = Tcl_DuplicateObj(subListObj);
TclListObjSetElement(NULL, parentList, index, subListObj);
}
/*
* The TclListObjSetElement() calls do not spoil the string rep
* of parentList, and that's fine for now, since all we've done
* so far is replace a list element with an unshared copy. The
* list value remains the same, so the string rep. is still
* valid, and unchanged, which is good because if this whole
* routine returns NULL, we'd like to leave no change to the
* value of the lset variable. Later on, when we set valueObj
* in its proper place, then all containing lists will have
* their values changed, and will need their string reps
* spoiled. We maintain a list of all those Tcl_Obj's (via a
* little internalrep surgery) so we can spoil them at that
* time.
*/
pendingInvalidatesPtr[numPendingInvalidates] = parentList;
++numPendingInvalidates;
}
} while (indexCount > 0);
/*
* Either we've detected and error condition, and exited the loop with
* result == TCL_ERROR, or we've successfully reached the last index, and
* we're ready to store valueObj. On success, we need to invalidate
* the string representations of intermediate lists whose contained
* list element would have changed.
*/
if (result == TCL_OK) {
while (numPendingInvalidates > 0) {
Tcl_Obj *objPtr;
--numPendingInvalidates;
objPtr = pendingInvalidatesPtr[numPendingInvalidates];
if (result == TCL_OK) {
/*
* We're going to store valueObj, so spoil string reps of all
* containing lists.
* TODO - historically, the storing of the internal rep was done
* because the ptr2 field of the internal rep was used to chain
* objects whose string rep needed to be invalidated. Now this
* is no longer the case, so replacing of the internal rep
* should not be needed. The TclInvalidateStringRep should
* suffice. Formulate a test case before changing.
*/
ListRep objInternalRep;
TclListObjGetRep(NULL, objPtr, &objInternalRep);
ListObjReplaceRepAndInvalidate(objPtr, &objInternalRep);
}
}
}
if (pendingInvalidatesPtr != pendingInvalidates)
Tcl_Free(pendingInvalidatesPtr);
if (result != TCL_OK) {
/*
* Error return; message is already in interp. Clean up any excess
* memory.
*/
if (retValueObj != listObj) {
Tcl_DecrRefCount(retValueObj);
}
return NULL;
}
/*
* Store valueObj in proper sublist and return. The -1 is to avoid a
* compiler warning (not a problem because we checked that we have a
* proper list - or something convertible to one - above).
*/
len = -1;
TclListObjLengthM(NULL, subListObj, &len);
if (valueObj == NULL) {
/* T:listrep-1.{4.2,5.4,6.1,7.1,8.3},2.{4,5}.4 */
Tcl_ListObjReplace(NULL, subListObj, index, 1, 0, NULL);
} else if (index == len) {
/* T:listrep-1.2.1,2.{2.3,9.3},3.{4,5,6}.3 */
Tcl_ListObjAppendElement(NULL, subListObj, valueObj);
} else {
/* T:listrep-1.{12.1,15.1,19.1},2.{10,13,16}.1 */
TclListObjSetElement(NULL, subListObj, index, valueObj);
TclInvalidateStringRep(subListObj);
}
Tcl_IncrRefCount(retValueObj);
return retValueObj;
}
/*
*----------------------------------------------------------------------
*
* TclListObjSetElement --
*
* Set a single element of a list to a specified value
*
* Results:
* The return value is normally TCL_OK. If listObj does not refer to a
* list object and cannot be converted to one, TCL_ERROR is returned and
* an error message will be left in the interpreter result if interp is
* not NULL. Similarly, if index designates an element outside the range
* [0..listLength-1], where listLength is the count of elements in the
* list object designated by listObj, TCL_ERROR is returned and an error
* message is left in the interpreter result.
*
* Side effects:
* Tcl_Panic if listObj designates a shared object. Otherwise, attempts
* to convert it to a list with a non-shared internal rep. Decrements the
* ref count of the object at the specified index within the list,
* replaces with the object designated by valueObj, and increments the
* ref count of the replacement object.
*
*----------------------------------------------------------------------
*/
int
TclListObjSetElement(
Tcl_Interp *interp, /* Tcl interpreter; used for error reporting
* if not NULL. */
Tcl_Obj *listObj, /* List object in which element should be
* stored. */
ListSizeT index, /* Index of element to store. */
Tcl_Obj *valueObj) /* Tcl object to store in the designated list
* element. */
{
ListRep listRep;
Tcl_Obj **elemPtrs; /* Pointers to elements of the list. */
ListSizeT elemCount; /* Number of elements in the list. */
/* Ensure that the listObj parameter designates an unshared list. */
if (Tcl_IsShared(listObj)) {
Tcl_Panic("%s called with shared object", "TclListObjSetElement");
}
if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
return TCL_ERROR;
}
elemCount = ListRepLength(&listRep);
/* Ensure that the index is in bounds. */
if (index>=elemCount) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"index \"%" TCL_Z_MODIFIER "u\" out of range", index));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX",
"OUTOFRANGE", NULL);
}
return TCL_ERROR;
}
/*
* Note - garbage collect this only AFTER checking indices above.
* Do not want to modify listrep and then not store it back in listObj.
*/
ListRepFreeUnreferenced(&listRep);
/* Replace a shared internal rep with an unshared copy */
if (listRep.storePtr->refCount > 1) {
ListRep newInternalRep;
/* T:listrep-2.{10,13,16}.1 */
/* TODO - leave extra space? */
ListRepClone(&listRep, &newInternalRep, LISTREP_PANIC_ON_FAIL);
listRep = newInternalRep;
} /* else T:listrep-1.{12.1,15.1,19.1} */
/* Retrieve element array AFTER potential cloning above */
ListRepElements(&listRep, elemCount, elemPtrs);
/*
* Add a reference to the new list element and remove from old before
* replacing it. Order is important!
*/
Tcl_IncrRefCount(valueObj);
Tcl_DecrRefCount(elemPtrs[index]);
elemPtrs[index] = valueObj;
/* Internal rep may be cloned so replace */
ListObjReplaceRepAndInvalidate(listObj, &listRep);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* FreeListInternalRep --
*
* Deallocate the storage associated with a list object's internal
* representation.
*
* Results:
* None.
*
* Side effects:
* Frees listPtr's List* internal representation, if no longer shared.
* May decrement the ref counts of element objects, which may free them.
*
*----------------------------------------------------------------------
*/
static void
FreeListInternalRep(
Tcl_Obj *listObj) /* List object with internal rep to free. */
{
ListRep listRep;
ListObjGetRep(listObj, &listRep);
if (listRep.storePtr->refCount-- <= 1) {
ObjArrayDecrRefs(
listRep.storePtr->slots,
listRep.storePtr->firstUsed, listRep.storePtr->numUsed);
Tcl_Free(listRep.storePtr);
}
if (listRep.spanPtr) {
ListSpanDecrRefs(listRep.spanPtr);
}
}
/*
*----------------------------------------------------------------------
*
* DupListInternalRep --
*
* Initialize the internal representation of a list Tcl_Obj to share the
* internal representation of an existing list object.
*
* Results:
* None.
*
* Side effects:
* The reference count of the List internal rep is incremented.
*
*----------------------------------------------------------------------
*/
static void
DupListInternalRep(
Tcl_Obj *srcObj, /* Object with internal rep to copy. */
Tcl_Obj *copyObj) /* Object with internal rep to set. */
{
ListRep listRep;
ListObjGetRep(srcObj, &listRep);
ListObjOverwriteRep(copyObj, &listRep);
}
/*
*----------------------------------------------------------------------
*
* SetListFromAny --
*
* Attempt to generate a list internal form for the Tcl object "objPtr".
*
* Results:
* The return value is TCL_OK or TCL_ERROR. If an error occurs during
* conversion, an error message is left in the interpreter's result
* unless "interp" is NULL.
*
* Side effects:
* If no error occurs, a list is stored as "objPtr"s internal
* representation.
*
*----------------------------------------------------------------------
*/
static int
SetListFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
Tcl_Obj **elemPtrs;
ListRep listRep;
/*
* Dictionaries are a special case; they have a string representation such
* that *all* valid dictionaries are valid lists. Hence we can convert
* more directly. Only do this when there's no existing string rep; if
* there is, it is the string rep that's authoritative (because it could
* describe duplicate keys).
*/
if (!TclHasStringRep(objPtr) && TclHasInternalRep(objPtr, &tclDictType)) {
Tcl_Obj *keyPtr, *valuePtr;
Tcl_DictSearch search;
int done;
ListSizeT size;
/*
* Create the new list representation. Note that we do not need to do
* anything with the string representation as the transformation (and
* the reverse back to a dictionary) are both order-preserving. Also
* note that since we know we've got a valid dictionary (by
* representation) we also know that fetching the size of the
* dictionary or iterating over it will not fail.
*/
Tcl_DictObjSize(NULL, objPtr, &size);
/* TODO - leave space in front and/or back? */
if (ListRepInitAttempt(
interp, size > 0 ? 2 * size : 1, NULL, &listRep)
!= TCL_OK) {
return TCL_ERROR;
}
LIST_ASSERT(listRep.spanPtr == NULL); /* Guard against future changes */
LIST_ASSERT(listRep.storePtr->firstUsed == 0);
LIST_ASSERT((listRep.storePtr->flags & LISTSTORE_CANONICAL) == 0);
listRep.storePtr->numUsed = 2 * size;
/* Populate the list representation. */
elemPtrs = listRep.storePtr->slots;
Tcl_DictObjFirst(NULL, objPtr, &search, &keyPtr, &valuePtr, &done);
while (!done) {
*elemPtrs++ = keyPtr;
*elemPtrs++ = valuePtr;
Tcl_IncrRefCount(keyPtr);
Tcl_IncrRefCount(valuePtr);
Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
}
} else {
ListSizeT estCount, length;
const char *limit, *nextElem = Tcl_GetStringFromObj(objPtr, &length);
/*
* Allocate enough space to hold a (Tcl_Obj *) for each
* (possible) list element.
*/
estCount = TclMaxListLength(nextElem, length, &limit);
estCount += (estCount == 0); /* Smallest list struct holds 1
* element. */
/* TODO - allocate additional space? */
if (ListRepInitAttempt(interp, estCount, NULL, &listRep)
!= TCL_OK) {
return TCL_ERROR;
}
LIST_ASSERT(listRep.spanPtr == NULL); /* Guard against future changes */
LIST_ASSERT(listRep.storePtr->firstUsed == 0);
elemPtrs = listRep.storePtr->slots;
/* Each iteration, parse and store a list element. */
while (nextElem < limit) {
const char *elemStart;
char *check;
ListSizeT elemSize;
int literal;
if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem,
&elemStart, &nextElem, &elemSize, &literal)) {
fail:
while (--elemPtrs >= listRep.storePtr->slots) {
Tcl_DecrRefCount(*elemPtrs);
}
Tcl_Free(listRep.storePtr);
return TCL_ERROR;
}
if (elemStart == limit) {
break;
}
TclNewObj(*elemPtrs);
TclInvalidateStringRep(*elemPtrs);
check = Tcl_InitStringRep(*elemPtrs, literal ? elemStart : NULL,
elemSize);
if (elemSize && check == NULL) {
MemoryAllocationError(interp, elemSize);
goto fail;
}
if (!literal) {
Tcl_InitStringRep(*elemPtrs, NULL,
TclCopyAndCollapse(elemSize, elemStart, check));
}
Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */
}
listRep.storePtr->numUsed =
elemPtrs - listRep.storePtr->slots;
}
LISTREP_CHECK(&listRep);
/*
* Store the new internalRep. We do this as late
* as possible to allow the conversion code, in particular
* Tcl_GetStringFromObj, to use the old internalRep.
*/
/*
* Note old string representation NOT to be invalidated.
* So do NOT use ListObjReplaceRepAndInvalidate. InternalRep to be freed AFTER
* IncrRefs so do not use ListObjOverwriteRep
*/
ListRepIncrRefs(&listRep);
TclFreeInternalRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = listRep.storePtr;
objPtr->internalRep.twoPtrValue.ptr2 = listRep.spanPtr;
objPtr->typePtr = &tclListType;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfList --
*
* Update the string representation for a list object. Note: This
* function does not invalidate an existing old string rep so storage
* will be lost if this has not already been done.
*
* Results:
* None.
*
* Side effects:
* The object's string is set to a valid string that results from the
* list-to-string conversion. This string will be empty if the list has
* no elements. The list internal representation should not be NULL and
* we assume it is not NULL.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfList(
Tcl_Obj *listObj) /* List object with string rep to update. */
{
# define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
ListSizeT numElems, i, length, bytesNeeded = 0;
const char *elem, *start;
char *dst;
Tcl_Obj **elemPtrs;
ListRep listRep;
ListObjGetRep(listObj, &listRep);
LISTREP_CHECK(&listRep);
ListRepElements(&listRep, numElems, elemPtrs);
/*
* Mark the list as being canonical; although it will now have a string
* rep, it is one we derived through proper "canonical" quoting and so
* it's known to be free from nasties relating to [concat] and [eval].
* However, we only do this if this is not a spanned list. Marking the
* storage canonical for a spanned list make ALL lists using the storage
* canonical which is not right. (Consider a list generated from a
* string and then this function called for a spanned list generated
* from it). On the other hand, a spanned list is always canonical
* (never generated from a string) so it does not have to be explicitly
* marked as such. The ListObjIsCanonical macro takes this into account.
* See the comments there.
*/
if (listRep.spanPtr == NULL) {
LIST_ASSERT(listRep.storePtr->firstUsed == 0);/* Invariant */
listRep.storePtr->flags |= LISTSTORE_CANONICAL;
}
/* Handle empty list case first, so rest of the routine is simpler. */
if (numElems == 0) {
Tcl_InitStringRep(listObj, NULL, 0);
return;
}
/* Pass 1: estimate space, gather flags. */
if (numElems <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
/* We know numElems <= LIST_MAX, so this is safe. */
flagPtr = (char *)Tcl_Alloc(numElems);
}
for (i = 0; i < numElems; i++) {
flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
elem = Tcl_GetStringFromObj(elemPtrs[i], &length);
bytesNeeded += TclScanElement(elem, length, flagPtr+i);
if (bytesNeeded > SIZE_MAX - numElems) {
Tcl_Panic("max size for a Tcl value (%" TCL_Z_MODIFIER "u bytes) exceeded", SIZE_MAX);
}
}
bytesNeeded += numElems - 1;
/*
* Pass 2: copy into string rep buffer.
*/
start = dst = Tcl_InitStringRep(listObj, NULL, bytesNeeded);
TclOOM(dst, bytesNeeded);
for (i = 0; i < numElems; i++) {
flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
elem = Tcl_GetStringFromObj(elemPtrs[i], &length);
dst += TclConvertElement(elem, length, dst, flagPtr[i]);
*dst++ = ' ';
}
/* Set the string length to what was actually written, the safe choice */
(void) Tcl_InitStringRep(listObj, NULL, dst - 1 - start);
if (flagPtr != localFlags) {
Tcl_Free(flagPtr);
}
}
/*
*------------------------------------------------------------------------
*
* TclListTestObj --
*
* Returns a list object with a specific internal rep and content.
* Used specifically for testing so span can be controlled explicitly.
*
* Results:
* Pointer to the Tcl_Obj containing the list.
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
Tcl_Obj *
TclListTestObj (int length, int leadingSpace, int endSpace)
{
if (length < 0)
length = 0;
if (leadingSpace < 0)
leadingSpace = 0;
if (endSpace < 0)
endSpace = 0;
ListRep listRep;
ListSizeT capacity;
Tcl_Obj *listObj;
TclNewObj(listObj);
/* Only a test object so ignoring overflow checks */
capacity = length + leadingSpace + endSpace;
if (capacity == 0) {
return listObj;
}
ListRepInit(capacity, NULL, 0, &listRep);
ListStore *storePtr = listRep.storePtr;
int i;
for (i = 0; i < length; ++i) {
storePtr->slots[i + leadingSpace] = Tcl_NewIntObj(i);
Tcl_IncrRefCount(storePtr->slots[i + leadingSpace]);
}
storePtr->firstUsed = leadingSpace;
storePtr->numUsed = length;
if (leadingSpace != 0) {
listRep.spanPtr = ListSpanNew(leadingSpace, length);
}
ListObjReplaceRepAndInvalidate(listObj, &listRep);
return listObj;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclLiteral.c.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 | #define REBUILD_MULTIPLIER 3 /* * Function prototypes for static functions in this file: */ | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | #define REBUILD_MULTIPLIER 3 /* * Function prototypes for static functions in this file: */ static size_t AddLocalLiteralEntry(CompileEnv *envPtr, Tcl_Obj *objPtr, int localHash); static void ExpandLocalLiteralArray(CompileEnv *envPtr); static size_t HashString(const char *string, size_t length); #ifdef TCL_COMPILE_DEBUG static LiteralEntry * LookupLiteralEntry(Tcl_Interp *interp, Tcl_Obj *objPtr); #endif |
| ︙ | ︙ | |||
350 351 352 353 354 355 356 |
Tcl_Obj *
TclFetchLiteral(
CompileEnv *envPtr, /* Points to the CompileEnv from which to
* fetch the registered literal value. */
size_t index) /* Index of the desired literal, as returned
* by prior call to TclRegisterLiteral() */
{
| | | 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 |
Tcl_Obj *
TclFetchLiteral(
CompileEnv *envPtr, /* Points to the CompileEnv from which to
* fetch the registered literal value. */
size_t index) /* Index of the desired literal, as returned
* by prior call to TclRegisterLiteral() */
{
if (index >= envPtr->literalArrayNext) {
return NULL;
}
return envPtr->literalArrayPtr[index].objPtr;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
383 384 385 386 387 388 389 | * is set directly from string, otherwise the string is freed. Typically, * a caller sets LITERAL_ON_HEAP if "string" is an already heap-allocated * buffer holding the result of backslash substitutions. * *---------------------------------------------------------------------- */ | | | 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 |
* is set directly from string, otherwise the string is freed. Typically,
* a caller sets LITERAL_ON_HEAP if "string" is an already heap-allocated
* buffer holding the result of backslash substitutions.
*
*----------------------------------------------------------------------
*/
size_t
TclRegisterLiteral(
void *ePtr, /* Points to the CompileEnv in whose object
* array an object is found or created. */
const char *bytes, /* Points to string for which to find or
* create an object in CompileEnv's object
* array. */
ssize_t length, /* Number of bytes in the string. If -1, the
|
| ︙ | ︙ | |||
603 604 605 606 607 608 609 | * Side effects: * Expands the literal array if necessary. Increments the refcount on the * literal object. * *---------------------------------------------------------------------- */ | | | | 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 |
* Side effects:
* Expands the literal array if necessary. Increments the refcount on the
* literal object.
*
*----------------------------------------------------------------------
*/
size_t
TclAddLiteralObj(
CompileEnv *envPtr,/* Points to CompileEnv in whose literal array
* the object is to be inserted. */
Tcl_Obj *objPtr, /* The object to insert into the array. */
LiteralEntry **litPtrPtr) /* The location where the pointer to the new
* literal entry should be stored. May be
* NULL. */
{
LiteralEntry *lPtr;
size_t objIndex;
if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) {
ExpandLocalLiteralArray(envPtr);
}
objIndex = envPtr->literalArrayNext;
envPtr->literalArrayNext++;
|
| ︙ | ︙ | |||
652 653 654 655 656 657 658 | * Side effects: * Expands the literal array if necessary. May rebuild the hash bucket * array of the CompileEnv's literal array if it becomes too large. * *---------------------------------------------------------------------- */ | | | | 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 |
* Side effects:
* Expands the literal array if necessary. May rebuild the hash bucket
* array of the CompileEnv's literal array if it becomes too large.
*
*----------------------------------------------------------------------
*/
static size_t
AddLocalLiteralEntry(
CompileEnv *envPtr,/* Points to CompileEnv in whose literal array
* the object is to be inserted. */
Tcl_Obj *objPtr, /* The literal to add to the CompileEnv. */
int localHash) /* Hash value for the literal's string. */
{
LiteralTable *localTablePtr = &envPtr->localLitTable;
LiteralEntry *localPtr;
size_t objIndex;
objIndex = TclAddLiteralObj(envPtr, objPtr, &localPtr);
/*
* Add the literal to the local table.
*/
|
| ︙ | ︙ |
Changes to generic/tclLoad.c.
| ︙ | ︙ | |||
306 307 308 309 310 311 312 |
* Figure out the prefix if it wasn't provided explicitly.
*/
if (prefix != NULL) {
Tcl_DStringAppend(&pfx, prefix, -1);
} else {
Tcl_Obj *splitPtr, *pkgGuessPtr;
| | | 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 |
* Figure out the prefix if it wasn't provided explicitly.
*/
if (prefix != NULL) {
Tcl_DStringAppend(&pfx, prefix, -1);
} else {
Tcl_Obj *splitPtr, *pkgGuessPtr;
size_t pElements;
const char *pkgGuess;
/*
* Threading note - this call used to be protected by a mutex.
*/
/*
|
| ︙ | ︙ | |||
1190 1191 1192 1193 1194 1195 1196 | * Storage for all of the InterpLibrary functions for interp get deleted. * *---------------------------------------------------------------------- */ static void LoadCleanupProc( | | | 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 |
* Storage for all of the InterpLibrary functions for interp get deleted.
*
*----------------------------------------------------------------------
*/
static void
LoadCleanupProc(
TCL_UNUSED(void *), /* Pointer to first InterpLibrary structure
* for interp. */
Tcl_Interp *interp)
{
InterpLibrary *ipPtr;
LoadedLibrary *libraryPtr;
while (1) {
|
| ︙ | ︙ |
Changes to generic/tclMain.c.
| ︙ | ︙ | |||
276 277 278 279 280 281 282 | * interpreted. * *---------------------------------------------------------------------- */ TCL_NORETURN void Tcl_MainEx( | | | | | 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 |
* interpreted.
*
*----------------------------------------------------------------------
*/
TCL_NORETURN void
Tcl_MainEx(
size_t argc, /* Number of arguments. */
TCHAR **argv, /* Array of argument strings. */
Tcl_AppInitProc *appInitProc,
/* Application-specific initialization
* function to call after most initialization
* but before starting to execute commands. */
Tcl_Interp *interp)
{
size_t i=0; /* argv[i] index */
Tcl_Obj *path, *resultPtr, *argvPtr, *appName;
const char *encodingName = NULL;
int code, exitCode = 0;
Tcl_MainLoopProc *mainLoopProc;
Tcl_Channel chan;
InteractiveState is;
TclpSetInitialEncodings();
if (argc + 1 > 1) {
--argc; /* consume argv[0] */
++i;
}
TclpFindExecutable ((const char *)argv [0]); /* nb: this could be NULL
* w/ (eg) an empty argv
* supplied to execve() */
|
| ︙ | ︙ | |||
322 323 324 325 326 327 328 | * Check whether first 3 args (argv[1] - argv[3]) look like * -encoding ENCODING FILENAME * or like * FILENAME */ /* mind argc is being adjusted as we proceed */ | | | | > > | | | 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 364 |
* Check whether first 3 args (argv[1] - argv[3]) look like
* -encoding ENCODING FILENAME
* or like
* FILENAME
*/
/* mind argc is being adjusted as we proceed */
if ((argc >= 3) && argv[1] && argv[2] && argv[3] && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
&& ('-' != argv[3][0])) {
Tcl_Obj *value = NewNativeObj(argv[2]);
Tcl_SetStartupScript(NewNativeObj(argv[3]),
TclGetString(value));
Tcl_DecrRefCount(value);
argc -= 3;
i += 3;
} else if ((argc >= 1) && argv[1] && ('-' != argv[1][0])) {
Tcl_SetStartupScript(NewNativeObj(argv[1]), NULL);
argc--;
i++;
}
}
path = Tcl_GetStartupScript(&encodingName);
if (path != NULL) {
appName = path;
} else if (argv[0]) {
appName = NewNativeObj(argv[0]);
} else {
appName = Tcl_NewStringObj("tclsh", -1);
}
Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY);
Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewWideIntObj(argc), TCL_GLOBAL_ONLY);
argvPtr = Tcl_NewListObj(0, NULL);
while (argc-- && argv[i]) {
Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(argv[i++]));
}
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
/*
* Set the "tcl_interactive" variable.
*/
|
| ︙ | ︙ |
Changes to generic/tclNamesp.c.
| ︙ | ︙ | |||
322 323 324 325 326 327 328 |
framePtr->nsPtr = nsPtr;
framePtr->isProcCallFrame = isProcCallFrame;
framePtr->objc = 0;
framePtr->objv = NULL;
framePtr->callerPtr = iPtr->framePtr;
framePtr->callerVarPtr = iPtr->varFramePtr;
if (iPtr->varFramePtr != NULL) {
| | | 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 |
framePtr->nsPtr = nsPtr;
framePtr->isProcCallFrame = isProcCallFrame;
framePtr->objc = 0;
framePtr->objv = NULL;
framePtr->callerPtr = iPtr->framePtr;
framePtr->callerVarPtr = iPtr->varFramePtr;
if (iPtr->varFramePtr != NULL) {
framePtr->level = iPtr->varFramePtr->level + 1U;
} else {
framePtr->level = 0;
}
framePtr->procPtr = NULL; /* no called procedure */
framePtr->varTablePtr = NULL; /* and no local variables */
framePtr->numCompiledLocals = 0;
framePtr->compiledLocals = NULL;
|
| ︙ | ︙ | |||
390 391 392 393 394 395 396 |
}
if (framePtr->varTablePtr != NULL) {
TclDeleteVars(iPtr, framePtr->varTablePtr);
Tcl_Free(framePtr->varTablePtr);
framePtr->varTablePtr = NULL;
}
| | | 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 |
}
if (framePtr->varTablePtr != NULL) {
TclDeleteVars(iPtr, framePtr->varTablePtr);
Tcl_Free(framePtr->varTablePtr);
framePtr->varTablePtr = NULL;
}
if (framePtr->numCompiledLocals + 1 > 1) {
TclDeleteCompiledLocalVars(iPtr, framePtr);
if (framePtr->localCachePtr->refCount-- <= 1) {
TclFreeLocalCache(interp, framePtr->localCachePtr);
}
framePtr->localCachePtr = NULL;
}
|
| ︙ | ︙ | |||
4032 4033 4034 4035 4036 4037 4038 |
NamespacePathCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
| | | | 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 |
NamespacePathCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
size_t nsObjc, i;
int result = TCL_ERROR;
Tcl_Obj **nsObjv;
Tcl_Namespace **namespaceList = NULL;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?pathList?");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
4064 4065 4066 4067 4068 4069 4070 |
return TCL_OK;
}
/*
* There is a path given, so parse it into an array of namespace pointers.
*/
| | | | 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 |
return TCL_OK;
}
/*
* There is a path given, so parse it into an array of namespace pointers.
*/
if (TclListObjGetElementsM(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) {
goto badNamespace;
}
if (nsObjc != 0) {
namespaceList = (Tcl_Namespace **)TclStackAlloc(interp,
sizeof(Tcl_Namespace *) * nsObjc);
for (i = 0; i < nsObjc; i++) {
if (TclGetNamespaceFromObj(interp, nsObjv[i],
&namespaceList[i]) != TCL_OK) {
goto badNamespace;
}
}
}
|
| ︙ | ︙ | |||
4424 4425 4426 4427 4428 4429 4430 |
int
Tcl_SetNamespaceUnknownHandler(
Tcl_Interp *interp, /* Interpreter in which the namespace
* exists. */
Tcl_Namespace *nsPtr, /* Namespace which is being updated. */
Tcl_Obj *handlerPtr) /* The new handler, or NULL to reset. */
{
| | | | 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 |
int
Tcl_SetNamespaceUnknownHandler(
Tcl_Interp *interp, /* Interpreter in which the namespace
* exists. */
Tcl_Namespace *nsPtr, /* Namespace which is being updated. */
Tcl_Obj *handlerPtr) /* The new handler, or NULL to reset. */
{
size_t lstlen = 0;
Namespace *currNsPtr = (Namespace *) nsPtr;
/*
* Ensure that we check for errors *first* before we change anything.
*/
if (handlerPtr != NULL) {
if (TclListObjLengthM(interp, handlerPtr, &lstlen) != TCL_OK) {
/*
* Not a list.
*/
return TCL_ERROR;
}
if (lstlen > 0) {
|
| ︙ | ︙ | |||
4973 4974 4975 4976 4977 4978 4979 |
/*
* Should not happen.
*/
return;
} else {
Tcl_HashEntry *hPtr
| | | 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 |
/*
* Should not happen.
*/
return;
} else {
Tcl_HashEntry *hPtr
= Tcl_FindHashEntry(&iPtr->varTraces, varPtr);
VarTrace *tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr);
if (tracePtr->traceProc != EstablishErrorInfoTraces) {
/*
* The most recent trace set on ::errorInfo is not the one the
* core itself puts on last. This means some other code is
* tracing the variable, and the additional trace(s) might be
|
| ︙ | ︙ | |||
5006 5007 5008 5009 5010 5011 5012 |
newObj = Tcl_DuplicateObj(iPtr->errorStack);
Tcl_DecrRefCount(iPtr->errorStack);
Tcl_IncrRefCount(newObj);
iPtr->errorStack = newObj;
}
if (iPtr->resetErrorStack) {
| | | | 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 |
newObj = Tcl_DuplicateObj(iPtr->errorStack);
Tcl_DecrRefCount(iPtr->errorStack);
Tcl_IncrRefCount(newObj);
iPtr->errorStack = newObj;
}
if (iPtr->resetErrorStack) {
size_t len;
iPtr->resetErrorStack = 0;
TclListObjLengthM(interp, iPtr->errorStack, &len);
/*
* Reset while keeping the list internalrep as much as possible.
*/
Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
if (pc != NULL) {
|
| ︙ | ︙ | |||
5044 5045 5046 5047 5048 5049 5050 |
} else if (iPtr->varFramePtr != iPtr->framePtr) {
/*
* uplevel case, [lappend errorstack UP $relativelevel]
*/
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral);
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewWideIntObj(
| | | 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 |
} else if (iPtr->varFramePtr != iPtr->framePtr) {
/*
* uplevel case, [lappend errorstack UP $relativelevel]
*/
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral);
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewWideIntObj(
(int)(iPtr->framePtr->level - iPtr->varFramePtr->level)));
} else if (iPtr->framePtr != iPtr->rootFramePtr) {
/*
* normal case, [lappend errorstack CALL [info level 0]]
*/
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral);
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj(
|
| ︙ | ︙ | |||
5091 5092 5093 5094 5095 5096 5097 |
newObj = Tcl_DuplicateObj(iPtr->errorStack);
Tcl_DecrRefCount(iPtr->errorStack);
Tcl_IncrRefCount(newObj);
iPtr->errorStack = newObj;
}
if (iPtr->resetErrorStack) {
| | | | 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 |
newObj = Tcl_DuplicateObj(iPtr->errorStack);
Tcl_DecrRefCount(iPtr->errorStack);
Tcl_IncrRefCount(newObj);
iPtr->errorStack = newObj;
}
if (iPtr->resetErrorStack) {
size_t len;
iPtr->resetErrorStack = 0;
TclListObjLengthM(interp, iPtr->errorStack, &len);
/*
* Reset while keeping the list internalrep as much as possible.
*/
Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral);
|
| ︙ | ︙ |
Changes to generic/tclNotify.c.
| ︙ | ︙ | |||
91 92 93 94 95 96 97 | static ThreadSpecificData *firstNotifierPtr = NULL; TCL_DECLARE_MUTEX(listLock) /* * Declarations for routines used only in this file. */ | | | | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 | static ThreadSpecificData *firstNotifierPtr = NULL; TCL_DECLARE_MUTEX(listLock) /* * Declarations for routines used only in this file. */ static int QueueEvent(ThreadSpecificData *tsdPtr, Tcl_Event *evPtr, int position); /* *---------------------------------------------------------------------- * * TclInitNotifier -- * * Initialize the thread local data structures for the notifier |
| ︙ | ︙ | |||
171 172 173 174 175 176 177 |
TclFinalizeNotifier(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ThreadSpecificData **prevPtrPtr;
Tcl_Event *evPtr, *hold;
if (!tsdPtr->initialized) {
| | < | 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 |
TclFinalizeNotifier(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ThreadSpecificData **prevPtrPtr;
Tcl_Event *evPtr, *hold;
if (!tsdPtr->initialized) {
return; /* Notifier not initialized for the current thread */
}
Tcl_MutexLock(&(tsdPtr->queueMutex));
for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL; ) {
hold = evPtr;
evPtr = evPtr->nextPtr;
Tcl_Free(hold);
|
| ︙ | ︙ | |||
306 307 308 309 310 311 312 |
Tcl_EventCheckProc *checkProc,
/* Function to call after waiting to see what
* happened. */
ClientData clientData) /* One-word argument to pass to setupProc and
* checkProc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
| | | 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 |
Tcl_EventCheckProc *checkProc,
/* Function to call after waiting to see what
* happened. */
ClientData clientData) /* One-word argument to pass to setupProc and
* checkProc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
EventSource *sourcePtr = (EventSource *)Tcl_Alloc(sizeof(EventSource));
sourcePtr->setupProc = setupProc;
sourcePtr->checkProc = checkProc;
sourcePtr->clientData = clientData;
sourcePtr->nextPtr = tsdPtr->firstEventSourcePtr;
tsdPtr->firstEventSourcePtr = sourcePtr;
}
|
| ︙ | ︙ | |||
388 389 390 391 392 393 394 |
void
Tcl_QueueEvent(
Tcl_Event *evPtr, /* Event to add to queue. The storage space
* must have been allocated the caller with
* malloc (Tcl_Alloc), and it becomes the
* property of the event queue. It will be
* freed after the event has been handled. */
| | | | 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 |
void
Tcl_QueueEvent(
Tcl_Event *evPtr, /* Event to add to queue. The storage space
* must have been allocated the caller with
* malloc (Tcl_Alloc), and it becomes the
* property of the event queue. It will be
* freed after the event has been handled. */
int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK,
* possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
QueueEvent(tsdPtr, evPtr, position);
}
/*
|
| ︙ | ︙ | |||
420 421 422 423 424 425 426 |
Tcl_ThreadQueueEvent(
Tcl_ThreadId threadId, /* Identifier for thread to use. */
Tcl_Event *evPtr, /* Event to add to queue. The storage space
* must have been allocated the caller with
* malloc (Tcl_Alloc), and it becomes the
* property of the event queue. It will be
* freed after the event has been handled. */
| | | | > > > | | | | > > > | | | > | 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 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 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 |
Tcl_ThreadQueueEvent(
Tcl_ThreadId threadId, /* Identifier for thread to use. */
Tcl_Event *evPtr, /* Event to add to queue. The storage space
* must have been allocated the caller with
* malloc (Tcl_Alloc), and it becomes the
* property of the event queue. It will be
* freed after the event has been handled. */
int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK,
* possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */
{
ThreadSpecificData *tsdPtr;
/*
* Find the notifier associated with the specified thread.
*/
Tcl_MutexLock(&listLock);
for (tsdPtr = firstNotifierPtr; tsdPtr && tsdPtr->threadId != threadId;
tsdPtr = tsdPtr->nextPtr) {
/* Empty loop body. */
}
/*
* Queue the event if there was a notifier associated with the thread.
*/
if (tsdPtr) {
if (QueueEvent(tsdPtr, evPtr, position)) {
Tcl_AlertNotifier(tsdPtr->clientData);
}
} else {
Tcl_Free(evPtr);
}
Tcl_MutexUnlock(&listLock);
}
/*
*----------------------------------------------------------------------
*
* QueueEvent --
*
* Insert an event into the specified thread's event queue at one of
* three positions: the head, the tail, or before a floating marker.
* Events inserted before the marker will be processed in first-in-
* first-out order, but before any events inserted at the tail of the
* queue. Events inserted at the head of the queue will be processed in
* last-in-first-out order.
*
* Results:
* For TCL_QUEUE_ALERT_IF_EMPTY the empty state before the
* operation is returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
QueueEvent(
ThreadSpecificData *tsdPtr, /* Handle to thread local data that indicates
* which event queue to use. */
Tcl_Event *evPtr, /* Event to add to queue. The storage space
* must have been allocated the caller with
* malloc (Tcl_Alloc), and it becomes the
* property of the event queue. It will be
* freed after the event has been handled. */
int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK,
* possibly combined with TCL_QUEUE_ALERT_IF_EMPTY */
{
Tcl_MutexLock(&(tsdPtr->queueMutex));
if (tsdPtr->firstEventPtr != NULL) {
position &= ~TCL_QUEUE_ALERT_IF_EMPTY;
}
if ((position & 3) == TCL_QUEUE_TAIL) {
/*
* Append the event on the end of the queue.
*/
evPtr->nextPtr = NULL;
if (tsdPtr->firstEventPtr == NULL) {
tsdPtr->firstEventPtr = evPtr;
} else {
tsdPtr->lastEventPtr->nextPtr = evPtr;
}
tsdPtr->lastEventPtr = evPtr;
} else if ((position & 3) == TCL_QUEUE_HEAD) {
/*
* Push the event on the head of the queue.
*/
evPtr->nextPtr = tsdPtr->firstEventPtr;
if (tsdPtr->firstEventPtr == NULL) {
tsdPtr->lastEventPtr = evPtr;
}
tsdPtr->firstEventPtr = evPtr;
} else if ((position & 3) == TCL_QUEUE_MARK) {
/*
* Insert the event after the current marker event and advance the
* marker to the new event.
*/
if (tsdPtr->markerEventPtr == NULL) {
evPtr->nextPtr = tsdPtr->firstEventPtr;
tsdPtr->firstEventPtr = evPtr;
} else {
evPtr->nextPtr = tsdPtr->markerEventPtr->nextPtr;
tsdPtr->markerEventPtr->nextPtr = evPtr;
}
tsdPtr->markerEventPtr = evPtr;
if (evPtr->nextPtr == NULL) {
tsdPtr->lastEventPtr = evPtr;
}
}
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
return position & TCL_QUEUE_ALERT_IF_EMPTY;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteEvents --
*
|
| ︙ | ︙ |
Changes to generic/tclOO.c.
| ︙ | ︙ | |||
133 134 135 136 137 138 139 | }; /* * Scripted parts of TclOO. First, the main script (cannot be outside this * file). */ | | | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 |
};
/*
* Scripted parts of TclOO. First, the main script (cannot be outside this
* file).
*/
static const char initScript[] =
#ifndef TCL_NO_DEPRECATED
"package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
#endif
"package ifneeded tcl::oo " TCLOO_PATCHLEVEL " {# Already present, OK?};"
"namespace eval ::oo { variable version " TCLOO_VERSION " };"
"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
/* "tcl_findLibrary tcloo $oo::version $oo::version" */
|
| ︙ | ︙ | |||
258 259 260 261 262 263 264 |
if (Tcl_EvalEx(interp, initScript, -1, 0) != TCL_OK) {
return TCL_ERROR;
}
#ifndef TCL_NO_DEPRECATED
Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL,
| | | | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 |
if (Tcl_EvalEx(interp, initScript, -1, 0) != TCL_OK) {
return TCL_ERROR;
}
#ifndef TCL_NO_DEPRECATED
Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL,
&tclOOStubs);
#endif
return Tcl_PkgProvideEx(interp, "tcl::oo", TCLOO_PATCHLEVEL,
&tclOOStubs);
}
/*
* ----------------------------------------------------------------------
*
* TclOOGetFoundation --
*
|
| ︙ | ︙ | |||
304 305 306 307 308 309 310 |
static Tcl_ThreadDataKey tsdKey;
ThreadLocalData *tsdPtr =
(ThreadLocalData *)Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
Foundation *fPtr = (Foundation *)Tcl_Alloc(sizeof(Foundation));
Tcl_Obj *namePtr;
Tcl_DString buffer;
Command *cmdPtr;
| | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 |
static Tcl_ThreadDataKey tsdKey;
ThreadLocalData *tsdPtr =
(ThreadLocalData *)Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
Foundation *fPtr = (Foundation *)Tcl_Alloc(sizeof(Foundation));
Tcl_Obj *namePtr;
Tcl_DString buffer;
Command *cmdPtr;
size_t i;
/*
* Initialize the structure that holds the OO system core. This is
* attached to the interpreter via an assocData entry; not very efficient,
* but the best we can do without hacking the core more.
*/
|
| ︙ | ︙ | |||
387 388 389 390 391 392 393 |
/*
* Finish setting up the class of classes by marking the 'new' method as
* private; classes, unlike general objects, must have explicit names. We
* also need to create the constructor for classes.
*/
TclNewLiteralStringObj(namePtr, "new");
| | | | 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 |
/*
* Finish setting up the class of classes by marking the 'new' method as
* private; classes, unlike general objects, must have explicit names. We
* also need to create the constructor for classes.
*/
TclNewLiteralStringObj(namePtr, "new");
TclNewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
namePtr /* keeps ref */, 0 /* private */, NULL, NULL);
fPtr->classCls->constructorPtr = (Method *) TclNewMethod(interp,
(Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);
/*
* Create non-object commands and plug ourselves into the Tcl [info]
* ensemble.
*/
|
| ︙ | ︙ | |||
956 957 958 959 960 961 962 |
void
TclOOReleaseClassContents(
Tcl_Interp *interp, /* The interpreter containing the class. */
Object *oPtr) /* The object representing the class. */
{
FOREACH_HASH_DECLS;
| | | 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 |
void
TclOOReleaseClassContents(
Tcl_Interp *interp, /* The interpreter containing the class. */
Object *oPtr) /* The object representing the class. */
{
FOREACH_HASH_DECLS;
size_t i;
Class *clsPtr = oPtr->classPtr, *tmpClsPtr;
Method *mPtr;
Foundation *fPtr = oPtr->fPtr;
Tcl_Obj *variableObj;
PrivateVariableMapping *privateVariable;
/*
|
| ︙ | ︙ | |||
1117 1118 1119 1120 1121 1122 1123 |
Foundation *fPtr = oPtr->fPtr;
FOREACH_HASH_DECLS;
Class *mixinPtr;
Method *mPtr;
Tcl_Obj *filterObj, *variableObj;
PrivateVariableMapping *privateVariable;
Tcl_Interp *interp = oPtr->fPtr->interp;
| | | 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 |
Foundation *fPtr = oPtr->fPtr;
FOREACH_HASH_DECLS;
Class *mixinPtr;
Method *mPtr;
Tcl_Obj *filterObj, *variableObj;
PrivateVariableMapping *privateVariable;
Tcl_Interp *interp = oPtr->fPtr->interp;
size_t i;
if (Destructing(oPtr)) {
/*
* TODO: Can ObjectNamespaceDeleted ever be called twice? If not,
* this guard could be removed.
*/
|
| ︙ | ︙ | |||
1358 1359 1360 1361 1362 1363 1364 |
int
TclOORemoveFromInstances(
Object *oPtr, /* The instance to remove. */
Class *clsPtr) /* The class (possibly) containing the
* reference to the instance. */
{
| > | | 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 |
int
TclOORemoveFromInstances(
Object *oPtr, /* The instance to remove. */
Class *clsPtr) /* The class (possibly) containing the
* reference to the instance. */
{
size_t i;
int res = 0;
Object *instPtr;
FOREACH(instPtr, clsPtr->instances) {
if (oPtr == instPtr) {
RemoveItem(Object, clsPtr->instances, i);
TclOODecrRefCount(oPtr);
res++;
|
| ︙ | ︙ | |||
1420 1421 1422 1423 1424 1425 1426 |
int
TclOORemoveFromMixins(
Class *mixinPtr, /* The mixin to remove. */
Object *oPtr) /* The object (possibly) containing the
* reference to the mixin. */
{
| > | | 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 |
int
TclOORemoveFromMixins(
Class *mixinPtr, /* The mixin to remove. */
Object *oPtr) /* The object (possibly) containing the
* reference to the mixin. */
{
size_t i;
int res = 0;
Class *mixPtr;
FOREACH(mixPtr, oPtr->mixins) {
if (mixinPtr == mixPtr) {
RemoveItem(Class, oPtr->mixins, i);
TclOODecrRefCount(mixPtr->thisPtr);
res++;
|
| ︙ | ︙ | |||
1455 1456 1457 1458 1459 1460 1461 |
int
TclOORemoveFromSubclasses(
Class *subPtr, /* The subclass to remove. */
Class *superPtr) /* The superclass to possibly remove the
* subclass reference from. */
{
| > | | 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 |
int
TclOORemoveFromSubclasses(
Class *subPtr, /* The subclass to remove. */
Class *superPtr) /* The superclass to possibly remove the
* subclass reference from. */
{
size_t i;
int res = 0;
Class *subclsPtr;
FOREACH(subclsPtr, superPtr->subclasses) {
if (subPtr == subclsPtr) {
RemoveItem(Class, superPtr->subclasses, i);
TclOODecrRefCount(subPtr->thisPtr);
res++;
|
| ︙ | ︙ | |||
1519 1520 1521 1522 1523 1524 1525 |
int
TclOORemoveFromMixinSubs(
Class *subPtr, /* The subclass to remove. */
Class *superPtr) /* The superclass to possibly remove the
* subclass reference from. */
{
| > | | 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 |
int
TclOORemoveFromMixinSubs(
Class *subPtr, /* The subclass to remove. */
Class *superPtr) /* The superclass to possibly remove the
* subclass reference from. */
{
size_t i;
int res = 0;
Class *subclsPtr;
FOREACH(subclsPtr, superPtr->mixinSubs) {
if (subPtr == subclsPtr) {
RemoveItem(Class, superPtr->mixinSubs, i);
TclOODecrRefCount(subPtr->thisPtr);
res++;
|
| ︙ | ︙ | |||
1659 1660 1661 1662 1663 1664 1665 |
Tcl_Interp *interp, /* Interpreter context. */
Tcl_Class cls, /* Class to create an instance of. */
const char *nameStr, /* Name of object to create, or NULL to ask
* the code to pick its own unique name. */
const char *nsNameStr, /* Name of namespace to create inside object,
* or NULL to ask the code to pick its own
* unique name. */
| | | | | 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 |
Tcl_Interp *interp, /* Interpreter context. */
Tcl_Class cls, /* Class to create an instance of. */
const char *nameStr, /* Name of object to create, or NULL to ask
* the code to pick its own unique name. */
const char *nsNameStr, /* Name of namespace to create inside object,
* or NULL to ask the code to pick its own
* unique name. */
size_t objc, /* Number of arguments. Negative value means
* do not call constructor. */
Tcl_Obj *const *objv, /* Argument list. */
size_t skip) /* Number of arguments to _not_ pass to the
* constructor. */
{
Class *classPtr = (Class *) cls;
Object *oPtr;
ClientData clientData[4];
oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
if (oPtr == NULL) {
return NULL;
}
/*
* Run constructors, except when objc < 0, which is a special flag case
* used for object cloning only.
*/
if (objc != TCL_INDEX_NONE) {
CallContext *contextPtr =
TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL);
if (contextPtr != NULL) {
int isRoot, result;
Tcl_InterpState state;
|
| ︙ | ︙ | |||
1727 1728 1729 1730 1731 1732 1733 |
Tcl_Interp *interp, /* Interpreter context. */
Tcl_Class cls, /* Class to create an instance of. */
const char *nameStr, /* Name of object to create, or NULL to ask
* the code to pick its own unique name. */
const char *nsNameStr, /* Name of namespace to create inside object,
* or NULL to ask the code to pick its own
* unique name. */
| | | | | | 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 |
Tcl_Interp *interp, /* Interpreter context. */
Tcl_Class cls, /* Class to create an instance of. */
const char *nameStr, /* Name of object to create, or NULL to ask
* the code to pick its own unique name. */
const char *nsNameStr, /* Name of namespace to create inside object,
* or NULL to ask the code to pick its own
* unique name. */
size_t objc, /* Number of arguments. Negative value means
* do not call constructor. */
Tcl_Obj *const *objv, /* Argument list. */
size_t skip, /* Number of arguments to _not_ pass to the
* constructor. */
Tcl_Object *objectPtr) /* Place to write the object reference upon
* successful allocation. */
{
Class *classPtr = (Class *) cls;
CallContext *contextPtr;
Tcl_InterpState state;
Object *oPtr;
oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
if (oPtr == NULL) {
return TCL_ERROR;
}
/*
* Run constructors, except when objc == TCL_INDEX_NONE (a special flag case used for
* object cloning only). If there aren't any constructors, we do nothing.
*/
if (objc == TCL_INDEX_NONE) {
*objectPtr = (Tcl_Object) oPtr;
return TCL_OK;
}
contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL);
if (contextPtr == NULL) {
*objectPtr = (Tcl_Object) oPtr;
return TCL_OK;
|
| ︙ | ︙ | |||
1924 1925 1926 1927 1928 1929 1930 |
Object *oPtr = (Object *) sourceObject, *o2Ptr;
FOREACH_HASH_DECLS;
Method *mPtr;
Class *mixinPtr;
CallContext *contextPtr;
Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
PrivateVariableMapping *privateVariable;
| > | | 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 |
Object *oPtr = (Object *) sourceObject, *o2Ptr;
FOREACH_HASH_DECLS;
Method *mPtr;
Class *mixinPtr;
CallContext *contextPtr;
Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
PrivateVariableMapping *privateVariable;
size_t i;
int result;
/*
* Sanity check.
*/
if (IsRootClass(oPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
|
| ︙ | ︙ | |||
2242 2243 2244 2245 2246 2247 2248 |
CloneObjectMethod(
Tcl_Interp *interp,
Object *oPtr,
Method *mPtr,
Tcl_Obj *namePtr)
{
if (mPtr->typePtr == NULL) {
| | | | | | | | 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 |
CloneObjectMethod(
Tcl_Interp *interp,
Object *oPtr,
Method *mPtr,
Tcl_Obj *namePtr)
{
if (mPtr->typePtr == NULL) {
TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
mPtr->flags & PUBLIC_METHOD, NULL, NULL);
} else if (mPtr->typePtr->cloneProc) {
ClientData newClientData;
if (mPtr->typePtr->cloneProc(interp, mPtr->clientData,
&newClientData) != TCL_OK) {
return TCL_ERROR;
}
TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData);
} else {
TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData);
}
return TCL_OK;
}
static int
CloneClassMethod(
Tcl_Interp *interp,
Class *clsPtr,
Method *mPtr,
Tcl_Obj *namePtr,
Method **m2PtrPtr)
{
Method *m2Ptr;
if (mPtr->typePtr == NULL) {
m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr,
namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL);
} else if (mPtr->typePtr->cloneProc) {
ClientData newClientData;
if (mPtr->typePtr->cloneProc(interp, mPtr->clientData,
&newClientData) != TCL_OK) {
return TCL_ERROR;
}
m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr,
namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
newClientData);
} else {
m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr,
namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
mPtr->clientData);
}
if (m2PtrPtr != NULL) {
*m2PtrPtr = m2Ptr;
}
return TCL_OK;
|
| ︙ | ︙ | |||
2341 2342 2343 2344 2345 2346 2347 |
return NULL;
}
/*
* There is a metadata store, so look in it for the given type.
*/
| | | 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 |
return NULL;
}
/*
* There is a metadata store, so look in it for the given type.
*/
hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, typePtr);
/*
* Return the metadata value if we found it, otherwise NULL.
*/
if (hPtr == NULL) {
return NULL;
|
| ︙ | ︙ | |||
2380 2381 2382 2383 2384 2385 2386 |
}
/*
* If the metadata is NULL, we're deleting the metadata for the type.
*/
if (metadata == NULL) {
| | | | 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 |
}
/*
* If the metadata is NULL, we're deleting the metadata for the type.
*/
if (metadata == NULL) {
hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, typePtr);
if (hPtr != NULL) {
typePtr->deleteProc(Tcl_GetHashValue(hPtr));
Tcl_DeleteHashEntry(hPtr);
}
return;
}
/*
* Otherwise we're attaching the metadata. Note that if there was already
* some metadata attached of this type, we delete that first.
*/
hPtr = Tcl_CreateHashEntry(clsPtr->metadataPtr, typePtr, &isNew);
if (!isNew) {
typePtr->deleteProc(Tcl_GetHashValue(hPtr));
}
Tcl_SetHashValue(hPtr, metadata);
}
ClientData
|
| ︙ | ︙ | |||
2421 2422 2423 2424 2425 2426 2427 |
return NULL;
}
/*
* There is a metadata store, so look in it for the given type.
*/
| | | 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 |
return NULL;
}
/*
* There is a metadata store, so look in it for the given type.
*/
hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, typePtr);
/*
* Return the metadata value if we found it, otherwise NULL.
*/
if (hPtr == NULL) {
return NULL;
|
| ︙ | ︙ | |||
2460 2461 2462 2463 2464 2465 2466 |
}
/*
* If the metadata is NULL, we're deleting the metadata for the type.
*/
if (metadata == NULL) {
| | | | 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 |
}
/*
* If the metadata is NULL, we're deleting the metadata for the type.
*/
if (metadata == NULL) {
hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, typePtr);
if (hPtr != NULL) {
typePtr->deleteProc(Tcl_GetHashValue(hPtr));
Tcl_DeleteHashEntry(hPtr);
}
return;
}
/*
* Otherwise we're attaching the metadata. Note that if there was already
* some metadata attached of this type, we delete that first.
*/
hPtr = Tcl_CreateHashEntry(oPtr->metadataPtr, typePtr, &isNew);
if (!isNew) {
typePtr->deleteProc(Tcl_GetHashValue(hPtr));
}
Tcl_SetHashValue(hPtr, metadata);
}
/*
|
| ︙ | ︙ | |||
2547 2548 2549 2550 2551 2552 2553 |
* invoke from, or NULL to traverse the whole
* chain including filters. */
int publicPrivate, /* Whether this is an invoke from a public
* context (PUBLIC_METHOD), a private context
* (PRIVATE_METHOD), or a *really* private
* context (any other value; conventionally
* 0). */
| | | 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 |
* invoke from, or NULL to traverse the whole
* chain including filters. */
int publicPrivate, /* Whether this is an invoke from a public
* context (PUBLIC_METHOD), a private context
* (PRIVATE_METHOD), or a *really* private
* context (any other value; conventionally
* 0). */
size_t objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Array of argument objects. It is assumed
* that the name of the method to invoke will
* be at index 1. */
{
switch (publicPrivate) {
case PUBLIC_METHOD:
return TclOOObjectCmdCore((Object *) object, interp, objc, objv,
|
| ︙ | ︙ | |||
2618 2619 2620 2621 2622 2623 2624 |
* ----------------------------------------------------------------------
*/
int
TclOOObjectCmdCore(
Object *oPtr, /* The object being invoked. */
Tcl_Interp *interp, /* The interpreter containing the object. */
| | | | 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 |
* ----------------------------------------------------------------------
*/
int
TclOOObjectCmdCore(
Object *oPtr, /* The object being invoked. */
Tcl_Interp *interp, /* The interpreter containing the object. */
size_t objc, /* How many arguments are being passed in. */
Tcl_Obj *const *objv, /* The array of arguments. */
int flags, /* Whether this is an invocation through the
* public or the private command interface. */
Class *startCls) /* Where to start in the call chain, or NULL
* if we are to start at the front with
* filters and the object's methods (which is
* the normal case). */
{
CallContext *contextPtr;
Tcl_Obj *methodNamePtr;
CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
Object *callerObjPtr = NULL;
Class *callerClsPtr = NULL;
int result;
/*
* If we've no method name, throw this directly into the unknown
* processing.
*/
if (objc + 1 < 3) {
flags |= FORCE_UNKNOWN;
methodNamePtr = NULL;
goto noMapping;
}
/*
* Determine if we're in a context that can see the extra, private methods
|
| ︙ | ︙ | |||
2790 2791 2792 2793 2794 2795 2796 |
* ----------------------------------------------------------------------
*/
int
Tcl_ObjectContextInvokeNext(
Tcl_Interp *interp,
Tcl_ObjectContext context,
| | | | 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 |
* ----------------------------------------------------------------------
*/
int
Tcl_ObjectContextInvokeNext(
Tcl_Interp *interp,
Tcl_ObjectContext context,
size_t objc,
Tcl_Obj *const *objv,
size_t skip)
{
CallContext *contextPtr = (CallContext *) context;
size_t savedIndex = contextPtr->index;
size_t savedSkip = contextPtr->skip;
int result;
if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
|
| ︙ | ︙ | |||
2862 2863 2864 2865 2866 2867 2868 |
return result;
}
int
TclNRObjectContextInvokeNext(
Tcl_Interp *interp,
Tcl_ObjectContext context,
| | | | 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 |
return result;
}
int
TclNRObjectContextInvokeNext(
Tcl_Interp *interp,
Tcl_ObjectContext context,
size_t objc,
Tcl_Obj *const *objv,
size_t skip)
{
CallContext *contextPtr = (CallContext *) context;
if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
/*
* We're at the end of the chain; generate an error message unless the
* interpreter is being torn down, in which case we might be getting
|
| ︙ | ︙ | |||
2991 2992 2993 2994 2995 2996 2997 |
*/
int
TclOOIsReachable(
Class *targetPtr,
Class *startPtr)
{
| | | 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 |
*/
int
TclOOIsReachable(
Class *targetPtr,
Class *startPtr)
{
size_t i;
Class *superPtr;
tailRecurse:
if (startPtr == targetPtr) {
return 1;
}
if (startPtr->superclasses.num == 1 && startPtr->mixins.num == 0) {
|
| ︙ | ︙ | |||
3084 3085 3086 3087 3088 3089 3090 |
Tcl_Object
Tcl_ObjectContextObject(
Tcl_ObjectContext context)
{
return (Tcl_Object) ((CallContext *)context)->oPtr;
}
| | | 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 |
Tcl_Object
Tcl_ObjectContextObject(
Tcl_ObjectContext context)
{
return (Tcl_Object) ((CallContext *)context)->oPtr;
}
size_t
Tcl_ObjectContextSkippedArgs(
Tcl_ObjectContext context)
{
return ((CallContext *)context)->skip;
}
Tcl_Namespace *
|
| ︙ | ︙ |
Changes to generic/tclOO.decls.
| ︙ | ︙ | |||
64 65 66 67 68 69 70 |
declare 12 {
Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr,
void *clientData)
}
declare 13 {
Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls,
| | | | | | | 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 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 |
declare 12 {
Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr,
void *clientData)
}
declare 13 {
Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls,
const char *nameStr, const char *nsNameStr, size_t objc,
Tcl_Obj *const *objv, size_t skip)
}
declare 14 {
int Tcl_ObjectDeleted(Tcl_Object object)
}
declare 15 {
int Tcl_ObjectContextIsFiltering(Tcl_ObjectContext context)
}
declare 16 {
Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context)
}
declare 17 {
Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context)
}
declare 18 {
size_t Tcl_ObjectContextSkippedArgs(Tcl_ObjectContext context)
}
declare 19 {
void *Tcl_ClassGetMetadata(Tcl_Class clazz,
const Tcl_ObjectMetadataType *typePtr)
}
declare 20 {
void Tcl_ClassSetMetadata(Tcl_Class clazz,
const Tcl_ObjectMetadataType *typePtr, void *metadata)
}
declare 21 {
void *Tcl_ObjectGetMetadata(Tcl_Object object,
const Tcl_ObjectMetadataType *typePtr)
}
declare 22 {
void Tcl_ObjectSetMetadata(Tcl_Object object,
const Tcl_ObjectMetadataType *typePtr, void *metadata)
}
declare 23 {
int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp,
Tcl_ObjectContext context, size_t objc, Tcl_Obj *const *objv,
size_t skip)
}
declare 24 {
Tcl_ObjectMapMethodNameProc *Tcl_ObjectGetMethodNameMapper(
Tcl_Object object)
}
declare 25 {
void Tcl_ObjectSetMethodNameMapper(Tcl_Object object,
|
| ︙ | ︙ | |||
131 132 133 134 135 136 137 138 139 140 141 142 143 144 |
}
declare 30 {
Tcl_Class Tcl_GetClassOfObject(Tcl_Object object)
}
declare 31 {
Tcl_Obj *Tcl_GetObjectClassName(Tcl_Interp *interp, Tcl_Object object)
}
######################################################################
# Private API, exposed to support advanced OO systems that plug in on top of
# TclOO; not intended for general use and does not have any commitment to
# long-term support.
#
| > > > > > > > > > > > > > > | 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 158 |
}
declare 30 {
Tcl_Class Tcl_GetClassOfObject(Tcl_Object object)
}
declare 31 {
Tcl_Obj *Tcl_GetObjectClassName(Tcl_Interp *interp, Tcl_Object object)
}
declare 32 {
int Tcl_MethodIsType2(Tcl_Method method, const Tcl_MethodType2 *typePtr,
void **clientDataPtr)
}
declare 33 {
Tcl_Method Tcl_NewInstanceMethod2(Tcl_Interp *interp, Tcl_Object object,
Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr,
void *clientData)
}
declare 34 {
Tcl_Method Tcl_NewMethod2(Tcl_Interp *interp, Tcl_Class cls,
Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr,
void *clientData)
}
######################################################################
# Private API, exposed to support advanced OO systems that plug in on top of
# TclOO; not intended for general use and does not have any commitment to
# long-term support.
#
|
| ︙ | ︙ | |||
166 167 168 169 170 171 172 |
}
declare 4 {
Method *TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr,
int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
ProcedureMethod **pmPtrPtr)
}
declare 5 {
| | | 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 |
}
declare 4 {
Method *TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr,
int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
ProcedureMethod **pmPtrPtr)
}
declare 5 {
int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, size_t objc,
Tcl_Obj *const *objv, int publicOnly, Class *startCls)
}
declare 6 {
int TclOOIsReachable(Class *targetPtr, Class *startPtr)
}
declare 7 {
Method *TclOONewForwardMethod(Tcl_Interp *interp, Class *clsPtr,
|
| ︙ | ︙ | |||
196 197 198 199 200 201 202 |
TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr,
ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj,
Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags,
void **internalTokenPtr)
}
declare 11 {
int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object,
| | | | | | | 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 236 237 238 239 240 241 |
TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr,
ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj,
Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags,
void **internalTokenPtr)
}
declare 11 {
int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object,
Tcl_Class startCls, int publicPrivate, size_t objc,
Tcl_Obj *const *objv)
}
declare 12 {
void TclOOObjectSetFilters(Object *oPtr, size_t numFilters,
Tcl_Obj *const *filters)
}
declare 13 {
void TclOOClassSetFilters(Tcl_Interp *interp, Class *classPtr,
size_t numFilters, Tcl_Obj *const *filters)
}
declare 14 {
void TclOOObjectSetMixins(Object *oPtr, size_t numMixins,
Class *const *mixins)
}
declare 15 {
void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr,
size_t numMixins, Class *const *mixins)
}
return
# Local Variables:
# mode: tcl
# End:
|
Changes to generic/tclOO.h.
| ︙ | ︙ | |||
20 21 22 23 24 25 26 | * * tests/oo.test * tests/ooNext2.test * unix/tclooConfig.sh * win/tclooConfig.sh */ | | | | | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 |
*
* tests/oo.test
* tests/ooNext2.test
* unix/tclooConfig.sh
* win/tclooConfig.sh
*/
#define TCLOO_VERSION "1.3"
#define TCLOO_PATCHLEVEL TCLOO_VERSION ".0"
#include "tcl.h"
/*
* For C++ compilers, use extern "C"
*/
#ifdef __cplusplus
extern "C" {
#endif
extern const char *TclOOInitializeStubs(
Tcl_Interp *, const char *version);
#define Tcl_OOInitStubs(interp) \
TclOOInitializeStubs((interp), TCLOO_PATCHLEVEL)
#ifndef USE_TCL_STUBS
# define TclOOInitializeStubs(interp, version) (TCLOO_PATCHLEVEL)
#endif
/*
* These are opaque types.
*/
|
| ︙ | ︙ | |||
58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 |
* Public datatypes for callbacks and structures used in the TIP#257 (OO)
* implementation. These are used to implement custom types of method calls
* and to allow the attachment of arbitrary data to objects and classes.
*/
typedef int (Tcl_MethodCallProc)(void *clientData, Tcl_Interp *interp,
Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv);
typedef void (Tcl_MethodDeleteProc)(void *clientData);
typedef int (Tcl_CloneProc)(Tcl_Interp *interp, void *oldClientData,
void **newClientData);
typedef void (Tcl_ObjectMetadataDeleteProc)(void *clientData);
typedef int (Tcl_ObjectMapMethodNameProc)(Tcl_Interp *interp,
Tcl_Object object, Tcl_Class *startClsPtr, Tcl_Obj *methodNameObj);
/*
* The type of a method implementation. This describes how to call the method
* implementation, how to delete it (when the object or class is deleted) and
* how to create a clone of it (when the object or class is copied).
*/
typedef struct {
int version; /* Structure version field. Always to be equal
| > > | > > > > > > > > > > > > > > > > > > > | 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 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 |
* Public datatypes for callbacks and structures used in the TIP#257 (OO)
* implementation. These are used to implement custom types of method calls
* and to allow the attachment of arbitrary data to objects and classes.
*/
typedef int (Tcl_MethodCallProc)(void *clientData, Tcl_Interp *interp,
Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv);
typedef int (Tcl_MethodCallProc2)(void *clientData, Tcl_Interp *interp,
Tcl_ObjectContext objectContext, size_t objc, Tcl_Obj *const *objv);
typedef void (Tcl_MethodDeleteProc)(void *clientData);
typedef int (Tcl_CloneProc)(Tcl_Interp *interp, void *oldClientData,
void **newClientData);
typedef void (Tcl_ObjectMetadataDeleteProc)(void *clientData);
typedef int (Tcl_ObjectMapMethodNameProc)(Tcl_Interp *interp,
Tcl_Object object, Tcl_Class *startClsPtr, Tcl_Obj *methodNameObj);
/*
* The type of a method implementation. This describes how to call the method
* implementation, how to delete it (when the object or class is deleted) and
* how to create a clone of it (when the object or class is copied).
*/
typedef struct {
int version; /* Structure version field. Always to be equal
* to TCL_OO_METHOD_VERSION_(1|CURRENT) in
* declarations. */
const char *name; /* Name of this type of method, mostly for
* debugging purposes. */
Tcl_MethodCallProc *callProc;
/* How to invoke this method. */
Tcl_MethodDeleteProc *deleteProc;
/* How to delete this method's type-specific
* data, or NULL if the type-specific data
* does not need deleting. */
Tcl_CloneProc *cloneProc; /* How to copy this method's type-specific
* data, or NULL if the type-specific data can
* be copied directly. */
} Tcl_MethodType;
typedef struct {
int version; /* Structure version field. Always to be equal
* to TCL_OO_METHOD_VERSION_2 in
* declarations. */
const char *name; /* Name of this type of method, mostly for
* debugging purposes. */
Tcl_MethodCallProc2 *callProc;
/* How to invoke this method. */
Tcl_MethodDeleteProc *deleteProc;
/* How to delete this method's type-specific
* data, or NULL if the type-specific data
* does not need deleting. */
Tcl_CloneProc *cloneProc; /* How to copy this method's type-specific
* data, or NULL if the type-specific data can
* be copied directly. */
} Tcl_MethodType2;
/*
* The correct value for the version field of the Tcl_MethodType structure.
* This allows new versions of the structure to be introduced without breaking
* binary compatibility.
*/
#define TCL_OO_METHOD_VERSION_1 1
#define TCL_OO_METHOD_VERSION_2 2
#define TCL_OO_METHOD_VERSION_CURRENT 1
/*
* Visibility constants for the flags parameter to Tcl_NewMethod and
* Tcl_NewInstanceMethod.
*/
|
| ︙ | ︙ |
Changes to generic/tclOOBasic.c.
| ︙ | ︙ | |||
72 73 74 75 76 77 78 | * Implementation for oo::class constructor. * * ---------------------------------------------------------------------- */ int TclOO_Class_Constructor( | | | | | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 |
* Implementation for oo::class constructor.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Class_Constructor(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
Tcl_Obj **invoke, *nameObj;
if (objc-1 > (int)Tcl_ObjectContextSkippedArgs(context)) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"?definitionScript?");
return TCL_ERROR;
} else if (objc == (int)Tcl_ObjectContextSkippedArgs(context)) {
return TCL_OK;
}
/*
* Make the class definition delegate. This is special; it doesn't reenter
* here (and the class definition delegate doesn't run any constructors).
*/
|
| ︙ | ︙ | |||
170 171 172 173 174 175 176 | * Implementation for oo::class->create method. * * ---------------------------------------------------------------------- */ int TclOO_Class_Create( | | | 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 |
* Implementation for oo::class->create method.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Class_Create(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
|
| ︙ | ︙ | |||
235 236 237 238 239 240 241 | * Implementation for oo::class->createWithNamespace method. * * ---------------------------------------------------------------------- */ int TclOO_Class_CreateNs( | | | 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 |
* Implementation for oo::class->createWithNamespace method.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Class_CreateNs(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
|
| ︙ | ︙ | |||
308 309 310 311 312 313 314 | * Implementation for oo::class->new method. * * ---------------------------------------------------------------------- */ int TclOO_Class_New( | | | 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 |
* Implementation for oo::class->new method.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Class_New(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
|
| ︙ | ︙ | |||
352 353 354 355 356 357 358 | * Implementation for oo::object->destroy method. * * ---------------------------------------------------------------------- */ int TclOO_Object_Destroy( | | | | 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 |
* Implementation for oo::object->destroy method.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Object_Destroy(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
CallContext *contextPtr;
if (objc != (int)Tcl_ObjectContextSkippedArgs(context)) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
if (!(oPtr->flags & DESTRUCTOR_CALLED)) {
oPtr->flags |= DESTRUCTOR_CALLED;
contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL,
|
| ︙ | ︙ | |||
413 414 415 416 417 418 419 | * Implementation for oo::object->eval method. * * ---------------------------------------------------------------------- */ int TclOO_Object_Eval( | | | 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 |
* Implementation for oo::object->eval method.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Object_Eval(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
CallContext *contextPtr = (CallContext *) context;
|
| ︙ | ︙ | |||
514 515 516 517 518 519 520 | * just creates a suitable error message. * * ---------------------------------------------------------------------- */ int TclOO_Object_Unknown( | | | 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 |
* just creates a suitable error message.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Object_Unknown(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
CallContext *contextPtr = (CallContext *) context;
|
| ︙ | ︙ | |||
620 621 622 623 624 625 626 | * Implementation of oo::object->variable method. * * ---------------------------------------------------------------------- */ int TclOO_Object_LinkVar( | | | | 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 |
* Implementation of oo::object->variable method.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Object_LinkVar(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Object object = Tcl_ObjectContextObject(context);
Namespace *savedNsPtr;
int i;
if ((size_t)objc < Tcl_ObjectContextSkippedArgs(context)) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"?varName ...?");
return TCL_ERROR;
}
/*
* A sanity check. Shouldn't ever happen. (This is all that remains of a
|
| ︙ | ︙ | |||
722 723 724 725 726 727 728 | * Implementation of the oo::object->varname method. * * ---------------------------------------------------------------------- */ int TclOO_Object_VarName( | | | | 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 |
* Implementation of the oo::object->varname method.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Object_VarName(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Var *varPtr, *aryVar;
Tcl_Obj *varNamePtr, *argPtr;
CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
const char *arg;
if ((int)Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"varName");
return TCL_ERROR;
}
argPtr = objv[objc-1];
arg = TclGetString(argPtr);
|
| ︙ | ︙ | |||
773 774 775 776 777 778 779 |
if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
CallContext *callerContext = (CallContext *)framePtr->clientData;
Method *mPtr = callerContext->callPtr->chain[
callerContext->index].mPtr;
PrivateVariableMapping *pvPtr;
| | | 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 |
if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
CallContext *callerContext = (CallContext *)framePtr->clientData;
Method *mPtr = callerContext->callPtr->chain[
callerContext->index].mPtr;
PrivateVariableMapping *pvPtr;
size_t i;
if (mPtr->declaringObjectPtr == oPtr) {
FOREACH_STRUCT(pvPtr, oPtr->privateVariables) {
if (!strcmp(TclGetString(pvPtr->variableObj),
TclGetString(argPtr))) {
argPtr = pvPtr->fullNameObj;
break;
|
| ︙ | ︙ | |||
860 861 862 863 864 865 866 | * method. * * ---------------------------------------------------------------------- */ int TclOONextObjCmd( | | | 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 |
* method.
*
* ----------------------------------------------------------------------
*/
int
TclOONextObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
CallFrame *framePtr = iPtr->varFramePtr;
Tcl_ObjectContext context;
|
| ︙ | ︙ | |||
896 897 898 899 900 901 902 |
TclNRAddCallback(interp, NextRestoreFrame, framePtr, NULL,NULL,NULL);
iPtr->varFramePtr = framePtr->callerVarPtr;
return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1);
}
int
TclOONextToObjCmd(
| | | 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 |
TclNRAddCallback(interp, NextRestoreFrame, framePtr, NULL,NULL,NULL);
iPtr->varFramePtr = framePtr->callerVarPtr;
return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1);
}
int
TclOONextToObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
CallFrame *framePtr = iPtr->varFramePtr;
Class *classPtr;
|
| ︙ | ︙ | |||
1029 1030 1031 1032 1033 1034 1035 | * the call context. * * ---------------------------------------------------------------------- */ int TclOOSelfObjCmd( | | | 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 |
* the call context.
*
* ----------------------------------------------------------------------
*/
int
TclOOSelfObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
static const char *const subcmds[] = {
"call", "caller", "class", "filter", "method", "namespace", "next",
"object", "target", NULL
|
| ︙ | ︙ | |||
1265 1266 1267 1268 1269 1270 1271 | * process. * * ---------------------------------------------------------------------- */ int TclOOCopyObjectCmd( | | | 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 |
* process.
*
* ----------------------------------------------------------------------
*/
int
TclOOCopyObjectCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Object oPtr, o2Ptr;
if (objc < 2 || objc > 4) {
|
| ︙ | ︙ |
Changes to generic/tclOOCall.c.
| ︙ | ︙ | |||
133 134 135 136 137 138 139 | static void DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr); static Tcl_NRPostProc FinalizeMethodRefs; static void FreeMethodNameRep(Tcl_Obj *objPtr); static inline int IsStillValid(CallChain *callPtr, Object *oPtr, int flags, int reuseMask); static Tcl_NRPostProc ResetFilterFlags; static Tcl_NRPostProc SetFilterFlags; | | | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 | static void DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr); static Tcl_NRPostProc FinalizeMethodRefs; static void FreeMethodNameRep(Tcl_Obj *objPtr); static inline int IsStillValid(CallChain *callPtr, Object *oPtr, int flags, int reuseMask); static Tcl_NRPostProc ResetFilterFlags; static Tcl_NRPostProc SetFilterFlags; static size_t SortMethodNames(Tcl_HashTable *namesPtr, int flags, const char ***stringsPtr); static inline void StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr); /* * Object type used to manage type caches attached to method names. */ |
| ︙ | ︙ | |||
302 303 304 305 306 307 308 | * in stack usage as possible. * * ---------------------------------------------------------------------- */ int TclOOInvokeContext( | | | 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 |
* in stack usage as possible.
*
* ----------------------------------------------------------------------
*/
int
TclOOInvokeContext(
void *clientData, /* The method call context. */
Tcl_Interp *interp, /* Interpreter for error reporting, and many
* other sorts of context handling (e.g.,
* commands, variables) depending on method
* implementation. */
int objc, /* The number of arguments. */
Tcl_Obj *const objv[]) /* The arguments as actually seen. */
{
|
| ︙ | ︙ | |||
365 366 367 368 369 370 371 |
contextPtr->oPtr->flags &= ~FILTER_HANDLING;
}
/*
* Run the method implementation.
*/
| > | > > > | | | | 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 |
contextPtr->oPtr->flags &= ~FILTER_HANDLING;
}
/*
* Run the method implementation.
*/
if (mPtr->typePtr->version < TCL_OO_METHOD_VERSION_2) {
return (mPtr->typePtr->callProc)(mPtr->clientData, interp,
(Tcl_ObjectContext) contextPtr, objc, objv);
}
return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp,
(Tcl_ObjectContext) contextPtr, objc, objv);
}
static int
SetFilterFlags(
void *data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *)data[0];
contextPtr->oPtr->flags |= FILTER_HANDLING;
return result;
}
static int
ResetFilterFlags(
void *data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *)data[0];
contextPtr->oPtr->flags &= ~FILTER_HANDLING;
return result;
}
static int
FinalizeMethodRefs(
void *data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *)data[0];
size_t i;
for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
|
| ︙ | ︙ | |||
441 442 443 444 445 446 447 |
Tcl_HashTable names; /* Tcl_Obj* method name to "wanted in list"
* mapping. */
Tcl_HashTable examinedClasses;
/* Used to track what classes have been looked
* at. Is set-like in nature and keyed by
* pointer to class. */
FOREACH_HASH_DECLS;
| | | 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 |
Tcl_HashTable names; /* Tcl_Obj* method name to "wanted in list"
* mapping. */
Tcl_HashTable examinedClasses;
/* Used to track what classes have been looked
* at. Is set-like in nature and keyed by
* pointer to class. */
FOREACH_HASH_DECLS;
size_t i, numStrings;
Class *mixinPtr;
Tcl_Obj *namePtr;
Method *mPtr;
Tcl_InitObjHashTable(&names);
Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS);
|
| ︙ | ︙ | |||
517 518 519 520 521 522 523 |
Tcl_DeleteHashTable(&examinedClasses);
numStrings = SortMethodNames(&names, flags, stringsPtr);
Tcl_DeleteHashTable(&names);
return numStrings;
}
| | | | 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 |
Tcl_DeleteHashTable(&examinedClasses);
numStrings = SortMethodNames(&names, flags, stringsPtr);
Tcl_DeleteHashTable(&names);
return numStrings;
}
size_t
TclOOGetSortedClassMethodList(
Class *clsPtr, /* The class to get the method names for. */
int flags, /* Whether we just want the public method
* names. */
const char ***stringsPtr) /* Where to write a pointer to the array of
* strings to. */
{
Tcl_HashTable names; /* Tcl_Obj* method name to "wanted in list"
* mapping. */
Tcl_HashTable examinedClasses;
/* Used to track what classes have been looked
* at. Is set-like in nature and keyed by
* pointer to class. */
size_t numStrings;
Tcl_InitObjHashTable(&names);
Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS);
/*
* Process method names from the class hierarchy and the mixin hierarchy.
*/
|
| ︙ | ︙ | |||
576 577 578 579 580 581 582 | * * Returns: * The length of the sorted list. * * ---------------------------------------------------------------------- */ | | | 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 |
*
* Returns:
* The length of the sorted list.
*
* ----------------------------------------------------------------------
*/
static size_t
SortMethodNames(
Tcl_HashTable *namesPtr, /* The table of names; unsorted, but contains
* whether the names are wanted and under what
* circumstances. */
int flags, /* Whether we are looking for unexported
* methods. Full private methods are handled
* on insertion to the table. */
|
| ︙ | ︙ | |||
682 683 684 685 686 687 688 |
* semantics are handled correctly. */
Tcl_HashTable *const examinedClassesPtr)
/* Hash table that tracks what classes have
* already been looked at. The keys are the
* pointers to the classes, and the values are
* immaterial. */
{
| | | | | 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 |
* semantics are handled correctly. */
Tcl_HashTable *const examinedClassesPtr)
/* Hash table that tracks what classes have
* already been looked at. The keys are the
* pointers to the classes, and the values are
* immaterial. */
{
size_t i;
/*
* If we've already started looking at this class, stop working on it now
* to prevent repeated work.
*/
if (Tcl_FindHashEntry(examinedClassesPtr, clsPtr)) {
return;
}
/*
* Scope all declarations so that the compiler can stand a good chance of
* making the recursive step highly efficient. We also hand-implement the
* tail-recursive case using a while loop; C compilers typically cannot do
* tail-recursion optimization usefully.
*/
while (1) {
FOREACH_HASH_DECLS;
Tcl_Obj *namePtr;
Method *mPtr;
int isNew;
(void) Tcl_CreateHashEntry(examinedClassesPtr, clsPtr,
&isNew);
if (!isNew) {
break;
}
if (clsPtr->mixins.num != 0) {
Class *mixinPtr;
|
| ︙ | ︙ | |||
765 766 767 768 769 770 771 |
Method *mPtr;
Tcl_Obj *namePtr;
FOREACH_HASH(namePtr, mPtr, methodsTablePtr) {
if (IS_PRIVATE(mPtr)) {
int isNew;
| | | | 769 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 |
Method *mPtr;
Tcl_Obj *namePtr;
FOREACH_HASH(namePtr, mPtr, methodsTablePtr) {
if (IS_PRIVATE(mPtr)) {
int isNew;
hPtr = Tcl_CreateHashEntry(namesPtr, namePtr, &isNew);
Tcl_SetHashValue(hPtr, INT2PTR(IN_LIST));
}
}
}
static inline void
AddStandardMethodName(
int flags,
Tcl_Obj *namePtr,
Method *mPtr,
Tcl_HashTable *namesPtr)
{
if (!IS_PRIVATE(mPtr)) {
int isNew;
Tcl_HashEntry *hPtr =
Tcl_CreateHashEntry(namesPtr, namePtr, &isNew);
if (isNew) {
int isWanted = (!WANT_PUBLIC(flags) || IS_PUBLIC(mPtr))
? IN_LIST : 0;
isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0);
Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
|
| ︙ | ︙ | |||
829 830 831 832 833 834 835 |
int flags) /* What sort of call chain are we building. */
{
Tcl_HashEntry *hPtr;
Method *mPtr;
int donePrivate = 0;
if (oPtr->methodsPtr) {
| | | 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 |
int flags) /* What sort of call chain are we building. */
{
Tcl_HashEntry *hPtr;
Method *mPtr;
int donePrivate = 0;
if (oPtr->methodsPtr) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodName);
if (hPtr != NULL) {
mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (IS_PRIVATE(mPtr)) {
AddMethodToCallChain(mPtr, cbPtr, NULL, NULL, flags);
donePrivate = 1;
}
}
|
| ︙ | ︙ | |||
873 874 875 876 877 878 879 |
/* Where to record what call chain entries
* have been processed. */
int flags, /* What sort of call chain are we building. */
Class *const filterDecl) /* The class that declared the filter. If
* NULL, either the filter was declared by the
* object or this isn't a filter. */
{
| > | | | 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 |
/* Where to record what call chain entries
* have been processed. */
int flags, /* What sort of call chain are we building. */
Class *const filterDecl) /* The class that declared the filter. If
* NULL, either the filter was declared by the
* object or this isn't a filter. */
{
size_t i;
int foundPrivate = 0, blockedUnexported = 0;
Tcl_HashEntry *hPtr;
Method *mPtr;
if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodNameObj);
if (hPtr != NULL) {
mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (!IS_PRIVATE(mPtr)) {
if (WANT_PUBLIC(flags)) {
if (!IS_PUBLIC(mPtr)) {
blockedUnexported = 1;
|
| ︙ | ︙ | |||
909 910 911 912 913 914 915 |
doneFilters, flags|TRAVERSED_MIXIN, filterDecl);
}
foundPrivate |= AddSimpleClassChainToCallContext(mixinPtr,
methodNameObj, cbPtr, doneFilters,
flags | TRAVERSED_MIXIN, filterDecl);
}
if (oPtr->methodsPtr && !blockedUnexported) {
| | | 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 |
doneFilters, flags|TRAVERSED_MIXIN, filterDecl);
}
foundPrivate |= AddSimpleClassChainToCallContext(mixinPtr,
methodNameObj, cbPtr, doneFilters,
flags | TRAVERSED_MIXIN, filterDecl);
}
if (oPtr->methodsPtr && !blockedUnexported) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodNameObj);
if (hPtr != NULL) {
mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (!IS_PRIVATE(mPtr)) {
AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
flags);
}
}
|
| ︙ | ︙ | |||
1086 1087 1088 1089 1090 1091 1092 | * IsStillValid -- * * Calculates whether the given call chain can be used for executing a * method for the given object. The condition on a chain from a cached * location being reusable is: * - Refers to the same object (same creation epoch), and * - Still across the same class structure (same global epoch), and | | | 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 | * IsStillValid -- * * Calculates whether the given call chain can be used for executing a * method for the given object. The condition on a chain from a cached * location being reusable is: * - Refers to the same object (same creation epoch), and * - Still across the same class structure (same global epoch), and * - Still across the same object structure (same local epoch), and * - No public/private/filter magic leakage (same flags, modulo the fact * that a public chain will satisfy a non-public call). * * ---------------------------------------------------------------------- */ static inline int |
| ︙ | ︙ | |||
1145 1146 1147 1148 1149 1150 1151 |
Tcl_Obj *cacheInThisObj) /* What object to cache in, or NULL if it is
* to be in the same object as the
* methodNameObj. */
{
CallContext *contextPtr;
CallChain *callPtr;
struct ChainBuilder cb;
| | | | 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 |
Tcl_Obj *cacheInThisObj) /* What object to cache in, or NULL if it is
* to be in the same object as the
* methodNameObj. */
{
CallContext *contextPtr;
CallChain *callPtr;
struct ChainBuilder cb;
size_t i, count;
int doFilters, donePrivate = 0;
Tcl_HashEntry *hPtr;
Tcl_HashTable doneFilters;
if (cacheInThisObj == NULL) {
cacheInThisObj = methodNameObj;
}
if (flags&(SPECIAL|FILTER_HANDLING) || (oPtr->flags&FILTER_HANDLING)) {
|
| ︙ | ︙ | |||
1201 1202 1203 1204 1205 1206 1207 |
}
Tcl_StoreInternalRep(cacheInThisObj, &methodNameType, NULL);
}
if (oPtr->flags & USE_CLASS_CACHE) {
if (oPtr->selfCls->classChainCache != NULL) {
hPtr = Tcl_FindHashEntry(oPtr->selfCls->classChainCache,
| | | | 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 |
}
Tcl_StoreInternalRep(cacheInThisObj, &methodNameType, NULL);
}
if (oPtr->flags & USE_CLASS_CACHE) {
if (oPtr->selfCls->classChainCache != NULL) {
hPtr = Tcl_FindHashEntry(oPtr->selfCls->classChainCache,
methodNameObj);
} else {
hPtr = NULL;
}
} else {
if (oPtr->chainCache != NULL) {
hPtr = Tcl_FindHashEntry(oPtr->chainCache,
methodNameObj);
} else {
hPtr = NULL;
}
}
if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
callPtr = (CallChain *)Tcl_GetHashValue(hPtr);
|
| ︙ | ︙ | |||
1338 1339 1340 1341 1342 1343 1344 |
if (oPtr->selfCls->classChainCache == NULL) {
oPtr->selfCls->classChainCache =
(Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->selfCls->classChainCache);
}
hPtr = Tcl_CreateHashEntry(oPtr->selfCls->classChainCache,
| | | | 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 |
if (oPtr->selfCls->classChainCache == NULL) {
oPtr->selfCls->classChainCache =
(Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->selfCls->classChainCache);
}
hPtr = Tcl_CreateHashEntry(oPtr->selfCls->classChainCache,
methodNameObj, &isNew);
} else {
if (oPtr->chainCache == NULL) {
oPtr->chainCache = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->chainCache);
}
hPtr = Tcl_CreateHashEntry(oPtr->chainCache,
methodNameObj, &isNew);
}
}
callPtr->refCount++;
Tcl_SetHashValue(hPtr, callPtr);
StashCallChain(cacheInThisObj, callPtr);
} else if (flags & CONSTRUCTOR) {
if (oPtr->selfCls->constructorChainPtr) {
|
| ︙ | ︙ | |||
1432 1433 1434 1435 1436 1437 1438 |
* the cache. This is made a bit more complex by the fact that there are
* multiple different layers of cache (in the Tcl_Obj, in the object, and
* in the class).
*/
if (clsPtr->classChainCache != NULL) {
hPtr = Tcl_FindHashEntry(clsPtr->classChainCache,
| | | 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 |
* the cache. This is made a bit more complex by the fact that there are
* multiple different layers of cache (in the Tcl_Obj, in the object, and
* in the class).
*/
if (clsPtr->classChainCache != NULL) {
hPtr = Tcl_FindHashEntry(clsPtr->classChainCache,
methodNameObj);
if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
callPtr = (CallChain *)Tcl_GetHashValue(hPtr);
if (IsStillValid(callPtr, &obj, flags, reuseMask)) {
callPtr->refCount++;
return callPtr;
|
| ︙ | ︙ | |||
1508 1509 1510 1511 1512 1513 1514 |
if (hPtr == NULL) {
int isNew;
if (clsPtr->classChainCache == NULL) {
clsPtr->classChainCache = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(clsPtr->classChainCache);
}
hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache,
| | | 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 |
if (hPtr == NULL) {
int isNew;
if (clsPtr->classChainCache == NULL) {
clsPtr->classChainCache = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(clsPtr->classChainCache);
}
hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache,
methodNameObj, &isNew);
}
callPtr->refCount++;
Tcl_SetHashValue(hPtr, callPtr);
StashCallChain(methodNameObj, callPtr);
}
return callPtr;
}
|
| ︙ | ︙ | |||
1541 1542 1543 1544 1545 1546 1547 |
Tcl_HashTable *const doneFilters,
/* Where to record what filters have been
* processed. Keys are objects, values are
* ignored. */
int flags) /* Whether we've gone along a mixin link
* yet. */
{
| > | | 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 |
Tcl_HashTable *const doneFilters,
/* Where to record what filters have been
* processed. Keys are objects, values are
* ignored. */
int flags) /* Whether we've gone along a mixin link
* yet. */
{
size_t i;
int clearedFlags =
flags & ~(TRAVERSED_MIXIN|OBJECT_MIXIN|BUILDING_MIXINS);
Class *superPtr, *mixinPtr;
Tcl_Obj *filterObj;
tailRecurse:
if (clsPtr == NULL) {
return;
|
| ︙ | ︙ | |||
1571 1572 1573 1574 1575 1576 1577 |
* override how filters work to extend their behaviour.
*/
if (MIXIN_CONSISTENT(flags)) {
FOREACH(filterObj, clsPtr->filters) {
int isNew;
| | < | 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 |
* override how filters work to extend their behaviour.
*/
if (MIXIN_CONSISTENT(flags)) {
FOREACH(filterObj, clsPtr->filters) {
int isNew;
(void) Tcl_CreateHashEntry(doneFilters, filterObj, &isNew);
if (isNew) {
AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr,
doneFilters, clearedFlags|BUILDING_MIXINS, clsPtr);
AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr,
doneFilters, clearedFlags, clsPtr);
}
}
|
| ︙ | ︙ | |||
1630 1631 1632 1633 1634 1635 1636 |
/* Where to record what call chain entries
* have been processed. */
int flags, /* What sort of call chain are we building. */
Class *const filterDecl) /* The class that declared the filter. If
* NULL, either the filter was declared by the
* object or this isn't a filter. */
{
| | | 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 |
/* Where to record what call chain entries
* have been processed. */
int flags, /* What sort of call chain are we building. */
Class *const filterDecl) /* The class that declared the filter. If
* NULL, either the filter was declared by the
* object or this isn't a filter. */
{
size_t i;
Class *superPtr;
/*
* We hard-code the tail-recursive form. It's by far the most common case
* *and* it is much more gentle on the stack.
*
* Note that mixins must be processed before the main class hierarchy.
|
| ︙ | ︙ | |||
1708 1709 1710 1711 1712 1713 1714 |
/* Where to record what call chain entries
* have been processed. */
int flags, /* What sort of call chain are we building. */
Class *const filterDecl) /* The class that declared the filter. If
* NULL, either the filter was declared by the
* object or this isn't a filter. */
{
| > | | 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 |
/* Where to record what call chain entries
* have been processed. */
int flags, /* What sort of call chain are we building. */
Class *const filterDecl) /* The class that declared the filter. If
* NULL, either the filter was declared by the
* object or this isn't a filter. */
{
size_t i;
int privateDanger = 0;
Class *superPtr;
/*
* We hard-code the tail-recursive form. It's by far the most common case
* *and* it is much more gentle on the stack.
*
* Note that mixins must be processed before the main class hierarchy.
|
| ︙ | ︙ | |||
1734 1735 1736 1737 1738 1739 1740 |
AddMethodToCallChain(classPtr->constructorPtr, cbPtr, doneFilters,
filterDecl, flags);
} else if (flags & DESTRUCTOR) {
AddMethodToCallChain(classPtr->destructorPtr, cbPtr, doneFilters,
filterDecl, flags);
} else {
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
| | | 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 |
AddMethodToCallChain(classPtr->constructorPtr, cbPtr, doneFilters,
filterDecl, flags);
} else if (flags & DESTRUCTOR) {
AddMethodToCallChain(classPtr->destructorPtr, cbPtr, doneFilters,
filterDecl, flags);
} else {
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
methodNameObj);
if (classPtr->flags & HAS_PRIVATE_METHODS) {
privateDanger |= 1;
}
if (hPtr != NULL) {
Method *mPtr = (Method *)Tcl_GetHashValue(hPtr);
|
| ︙ | ︙ | |||
1821 1822 1823 1824 1825 1826 1827 |
* special because it's a filter method). The second word is the name of
* the method in question (which differs for "unknown" and "filter" types)
* and the third word is the full name of the class that declares the
* method (or "object" if it is declared on the instance).
*/
objv = (Tcl_Obj **)TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
| | | 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 |
* special because it's a filter method). The second word is the name of
* the method in question (which differs for "unknown" and "filter" types)
* and the third word is the full name of the class that declares the
* method (or "object" if it is declared on the instance).
*/
objv = (Tcl_Obj **)TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
for (i = 0 ; i < (size_t)callPtr->numChain ; i++) {
struct MInvoke *miPtr = &callPtr->chain[i];
descObjs[0] =
miPtr->isFilter ? filterLiteral :
callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj :
IS_PRIVATE(miPtr->mPtr) ? privateLiteral :
methodLiteral;
|
| ︙ | ︙ | |||
1949 1950 1951 1952 1953 1954 1955 |
Object *const oPtr, /* Object to add define chain entries for. */
DefineChain *const definePtr,
/* Where to add the define chain entries. */
int flags) /* What sort of define chain are we
* building. */
{
Class *mixinPtr;
| | | 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 |
Object *const oPtr, /* Object to add define chain entries for. */
DefineChain *const definePtr,
/* Where to add the define chain entries. */
int flags) /* What sort of define chain are we
* building. */
{
Class *mixinPtr;
size_t i;
FOREACH(mixinPtr, oPtr->mixins) {
AddSimpleClassDefineNamespaces(mixinPtr, definePtr,
flags | TRAVERSED_MIXIN);
}
AddSimpleClassDefineNamespaces(oPtr->selfCls, definePtr, flags);
|
| ︙ | ︙ | |||
1978 1979 1980 1981 1982 1983 1984 |
AddSimpleClassDefineNamespaces(
Class *classPtr, /* Class to add the define chain entries for. */
DefineChain *const definePtr,
/* Where to add the define chain entries. */
int flags) /* What sort of define chain are we
* building. */
{
| | | 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 |
AddSimpleClassDefineNamespaces(
Class *classPtr, /* Class to add the define chain entries for. */
DefineChain *const definePtr,
/* Where to add the define chain entries. */
int flags) /* What sort of define chain are we
* building. */
{
size_t i;
Class *superPtr;
/*
* We hard-code the tail-recursive form. It's by far the most common case
* *and* it is much more gentle on the stack.
*/
|
| ︙ | ︙ |
Changes to generic/tclOODecls.h.
| ︙ | ︙ | |||
65 66 67 68 69 70 71 | TCLAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, void *clientData); /* 13 */ TCLAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, | | | | | | | 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 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 | TCLAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, void *clientData); /* 13 */ TCLAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, size_t objc, Tcl_Obj *const *objv, size_t skip); /* 14 */ TCLAPI int Tcl_ObjectDeleted(Tcl_Object object); /* 15 */ TCLAPI int Tcl_ObjectContextIsFiltering( Tcl_ObjectContext context); /* 16 */ TCLAPI Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); /* 17 */ TCLAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); /* 18 */ TCLAPI size_t Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context); /* 19 */ TCLAPI void * Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 20 */ TCLAPI void Tcl_ClassSetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, void *metadata); /* 21 */ TCLAPI void * Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 22 */ TCLAPI void Tcl_ObjectSetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, void *metadata); /* 23 */ TCLAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, size_t objc, Tcl_Obj *const *objv, size_t skip); /* 24 */ TCLAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( Tcl_Object object); /* 25 */ TCLAPI void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 26 */ |
| ︙ | ︙ | |||
119 120 121 122 123 124 125 126 127 128 129 130 131 132 |
/* 29 */
TCLAPI int Tcl_MethodIsPrivate(Tcl_Method method);
/* 30 */
TCLAPI Tcl_Class Tcl_GetClassOfObject(Tcl_Object object);
/* 31 */
TCLAPI Tcl_Obj * Tcl_GetObjectClassName(Tcl_Interp *interp,
Tcl_Object object);
typedef struct {
const struct TclOOIntStubs *tclOOIntStubs;
} TclOOStubHooks;
typedef struct TclOOStubs {
int magic;
| > > > > > > > > > > > > > > | 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 |
/* 29 */
TCLAPI int Tcl_MethodIsPrivate(Tcl_Method method);
/* 30 */
TCLAPI Tcl_Class Tcl_GetClassOfObject(Tcl_Object object);
/* 31 */
TCLAPI Tcl_Obj * Tcl_GetObjectClassName(Tcl_Interp *interp,
Tcl_Object object);
/* 32 */
TCLAPI int Tcl_MethodIsType2(Tcl_Method method,
const Tcl_MethodType2 *typePtr,
void **clientDataPtr);
/* 33 */
TCLAPI Tcl_Method Tcl_NewInstanceMethod2(Tcl_Interp *interp,
Tcl_Object object, Tcl_Obj *nameObj,
int flags, const Tcl_MethodType2 *typePtr,
void *clientData);
/* 34 */
TCLAPI Tcl_Method Tcl_NewMethod2(Tcl_Interp *interp, Tcl_Class cls,
Tcl_Obj *nameObj, int flags,
const Tcl_MethodType2 *typePtr,
void *clientData);
typedef struct {
const struct TclOOIntStubs *tclOOIntStubs;
} TclOOStubHooks;
typedef struct TclOOStubs {
int magic;
|
| ︙ | ︙ | |||
141 142 143 144 145 146 147 |
Tcl_Class (*tcl_MethodDeclarerClass) (Tcl_Method method); /* 6 */
Tcl_Object (*tcl_MethodDeclarerObject) (Tcl_Method method); /* 7 */
int (*tcl_MethodIsPublic) (Tcl_Method method); /* 8 */
int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType *typePtr, void **clientDataPtr); /* 9 */
Tcl_Obj * (*tcl_MethodName) (Tcl_Method method); /* 10 */
Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, void *clientData); /* 11 */
Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, void *clientData); /* 12 */
| | | | > > > | 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 |
Tcl_Class (*tcl_MethodDeclarerClass) (Tcl_Method method); /* 6 */
Tcl_Object (*tcl_MethodDeclarerObject) (Tcl_Method method); /* 7 */
int (*tcl_MethodIsPublic) (Tcl_Method method); /* 8 */
int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType *typePtr, void **clientDataPtr); /* 9 */
Tcl_Obj * (*tcl_MethodName) (Tcl_Method method); /* 10 */
Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, void *clientData); /* 11 */
Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, void *clientData); /* 12 */
Tcl_Object (*tcl_NewObjectInstance) (Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, size_t objc, Tcl_Obj *const *objv, size_t skip); /* 13 */
int (*tcl_ObjectDeleted) (Tcl_Object object); /* 14 */
int (*tcl_ObjectContextIsFiltering) (Tcl_ObjectContext context); /* 15 */
Tcl_Method (*tcl_ObjectContextMethod) (Tcl_ObjectContext context); /* 16 */
Tcl_Object (*tcl_ObjectContextObject) (Tcl_ObjectContext context); /* 17 */
size_t (*tcl_ObjectContextSkippedArgs) (Tcl_ObjectContext context); /* 18 */
void * (*tcl_ClassGetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 19 */
void (*tcl_ClassSetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, void *metadata); /* 20 */
void * (*tcl_ObjectGetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 21 */
void (*tcl_ObjectSetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, void *metadata); /* 22 */
int (*tcl_ObjectContextInvokeNext) (Tcl_Interp *interp, Tcl_ObjectContext context, size_t objc, Tcl_Obj *const *objv, size_t skip); /* 23 */
Tcl_ObjectMapMethodNameProc * (*tcl_ObjectGetMethodNameMapper) (Tcl_Object object); /* 24 */
void (*tcl_ObjectSetMethodNameMapper) (Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 25 */
void (*tcl_ClassSetConstructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 26 */
void (*tcl_ClassSetDestructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */
Tcl_Obj * (*tcl_GetObjectName) (Tcl_Interp *interp, Tcl_Object object); /* 28 */
int (*tcl_MethodIsPrivate) (Tcl_Method method); /* 29 */
Tcl_Class (*tcl_GetClassOfObject) (Tcl_Object object); /* 30 */
Tcl_Obj * (*tcl_GetObjectClassName) (Tcl_Interp *interp, Tcl_Object object); /* 31 */
int (*tcl_MethodIsType2) (Tcl_Method method, const Tcl_MethodType2 *typePtr, void **clientDataPtr); /* 32 */
Tcl_Method (*tcl_NewInstanceMethod2) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, void *clientData); /* 33 */
Tcl_Method (*tcl_NewMethod2) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, void *clientData); /* 34 */
} TclOOStubs;
extern const TclOOStubs *tclOOStubsPtr;
#ifdef __cplusplus
}
#endif
|
| ︙ | ︙ | |||
238 239 240 241 242 243 244 245 246 247 248 249 250 | (tclOOStubsPtr->tcl_GetObjectName) /* 28 */ #define Tcl_MethodIsPrivate \ (tclOOStubsPtr->tcl_MethodIsPrivate) /* 29 */ #define Tcl_GetClassOfObject \ (tclOOStubsPtr->tcl_GetClassOfObject) /* 30 */ #define Tcl_GetObjectClassName \ (tclOOStubsPtr->tcl_GetObjectClassName) /* 31 */ #endif /* defined(USE_TCLOO_STUBS) */ /* !END!: Do not edit above this line. */ #endif /* _TCLOODECLS */ | > > > > > > | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 | (tclOOStubsPtr->tcl_GetObjectName) /* 28 */ #define Tcl_MethodIsPrivate \ (tclOOStubsPtr->tcl_MethodIsPrivate) /* 29 */ #define Tcl_GetClassOfObject \ (tclOOStubsPtr->tcl_GetClassOfObject) /* 30 */ #define Tcl_GetObjectClassName \ (tclOOStubsPtr->tcl_GetObjectClassName) /* 31 */ #define Tcl_MethodIsType2 \ (tclOOStubsPtr->tcl_MethodIsType2) /* 32 */ #define Tcl_NewInstanceMethod2 \ (tclOOStubsPtr->tcl_NewInstanceMethod2) /* 33 */ #define Tcl_NewMethod2 \ (tclOOStubsPtr->tcl_NewMethod2) /* 34 */ #endif /* defined(USE_TCLOO_STUBS) */ /* !END!: Do not edit above this line. */ #endif /* _TCLOODECLS */ |
Changes to generic/tclOODefineCmds.c.
| ︙ | ︙ | |||
245 246 247 248 249 250 251 |
*
* ----------------------------------------------------------------------
*/
void
TclOOObjectSetFilters(
Object *oPtr,
| | | | 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 |
*
* ----------------------------------------------------------------------
*/
void
TclOOObjectSetFilters(
Object *oPtr,
size_t numFilters,
Tcl_Obj *const *filters)
{
size_t i;
if (oPtr->filters.num) {
Tcl_Obj *filterObj;
FOREACH(filterObj, oPtr->filters) {
Tcl_DecrRefCount(filterObj);
}
|
| ︙ | ︙ | |||
305 306 307 308 309 310 311 |
* ----------------------------------------------------------------------
*/
void
TclOOClassSetFilters(
Tcl_Interp *interp,
Class *classPtr,
| | | | 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 |
* ----------------------------------------------------------------------
*/
void
TclOOClassSetFilters(
Tcl_Interp *interp,
Class *classPtr,
size_t numFilters,
Tcl_Obj *const *filters)
{
size_t i;
if (classPtr->filters.num) {
Tcl_Obj *filterObj;
FOREACH(filterObj, classPtr->filters) {
Tcl_DecrRefCount(filterObj);
}
|
| ︙ | ︙ | |||
367 368 369 370 371 372 373 |
*
* ----------------------------------------------------------------------
*/
void
TclOOObjectSetMixins(
Object *oPtr,
| | | | 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 |
*
* ----------------------------------------------------------------------
*/
void
TclOOObjectSetMixins(
Object *oPtr,
size_t numMixins,
Class *const *mixins)
{
Class *mixinPtr;
size_t i;
if (numMixins == 0) {
if (oPtr->mixins.num != 0) {
FOREACH(mixinPtr, oPtr->mixins) {
TclOORemoveFromInstances(oPtr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
|
| ︙ | ︙ | |||
428 429 430 431 432 433 434 |
* ----------------------------------------------------------------------
*/
void
TclOOClassSetMixins(
Tcl_Interp *interp,
Class *classPtr,
| | | | 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 |
* ----------------------------------------------------------------------
*/
void
TclOOClassSetMixins(
Tcl_Interp *interp,
Class *classPtr,
size_t numMixins,
Class *const *mixins)
{
Class *mixinPtr;
size_t i;
if (numMixins == 0) {
if (classPtr->mixins.num != 0) {
FOREACH(mixinPtr, classPtr->mixins) {
TclOORemoveFromMixinSubs(classPtr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
|
| ︙ | ︙ | |||
481 482 483 484 485 486 487 |
* Helpers for installing standard and private variable maps.
*
* ----------------------------------------------------------------------
*/
static inline void
InstallStandardVariableMapping(
VariableNameList *vnlPtr,
| | > | | 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 |
* Helpers for installing standard and private variable maps.
*
* ----------------------------------------------------------------------
*/
static inline void
InstallStandardVariableMapping(
VariableNameList *vnlPtr,
size_t varc,
Tcl_Obj *const *varv)
{
Tcl_Obj *variableObj;
size_t i, n;
int created;
Tcl_HashTable uniqueTable;
for (i=0 ; i<varc ; i++) {
Tcl_IncrRefCount(varv[i]);
}
FOREACH(variableObj, *vnlPtr) {
Tcl_DecrRefCount(variableObj);
|
| ︙ | ︙ | |||
530 531 532 533 534 535 536 |
Tcl_DeleteHashTable(&uniqueTable);
}
}
static inline void
InstallPrivateVariableMapping(
PrivateVariableList *pvlPtr,
| | > | | 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 |
Tcl_DeleteHashTable(&uniqueTable);
}
}
static inline void
InstallPrivateVariableMapping(
PrivateVariableList *pvlPtr,
size_t varc,
Tcl_Obj *const *varv,
int creationEpoch)
{
PrivateVariableMapping *privatePtr;
size_t i, n;
int created;
Tcl_HashTable uniqueTable;
for (i=0 ; i<varc ; i++) {
Tcl_IncrRefCount(varv[i]);
}
FOREACH_STRUCT(privatePtr, *pvlPtr) {
Tcl_DecrRefCount(privatePtr->variableObj);
|
| ︙ | ︙ | |||
617 618 619 620 621 622 623 | noSuchMethod: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "method %s does not exist", TclGetString(fromPtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(fromPtr), NULL); return TCL_ERROR; } | | | | < | 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 652 653 654 655 656 |
noSuchMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"method %s does not exist", TclGetString(fromPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(fromPtr), NULL);
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, fromPtr);
if (hPtr == NULL) {
goto noSuchMethod;
}
if (toPtr) {
newHPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, toPtr,
&isNew);
if (hPtr == newHPtr) {
renameToSelf:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot rename method to itself", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", NULL);
return TCL_ERROR;
} else if (!isNew) {
renameToExisting:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"method called %s already exists",
TclGetString(toPtr)));
Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_OVER", NULL);
return TCL_ERROR;
}
}
} else {
hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, fromPtr);
if (hPtr == NULL) {
goto noSuchMethod;
}
if (toPtr) {
newHPtr = Tcl_CreateHashEntry(&oPtr->classPtr->classMethods,
(char *) toPtr, &isNew);
if (hPtr == newHPtr) {
|
| ︙ | ︙ | |||
691 692 693 694 695 696 697 | * prefix of. * * ---------------------------------------------------------------------- */ int TclOOUnknownDefinition( | | | 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 |
* prefix of.
*
* ----------------------------------------------------------------------
*/
int
TclOOUnknownDefinition(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
|
| ︙ | ︙ | |||
1028 1029 1030 1031 1032 1033 1034 |
Tcl_Namespace *nsPtr,
int cmdIndex,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *objPtr, *obj2Ptr, **objs;
Tcl_Command cmd;
| | > | 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 |
Tcl_Namespace *nsPtr,
int cmdIndex,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *objPtr, *obj2Ptr, **objs;
Tcl_Command cmd;
int isRoot, result, offset = cmdIndex + 1;
size_t dummy;
/*
* More than one argument: fire them through the ensemble processing
* engine so that everything appears to be good and proper in error
* messages. Note that we cannot just concatenate and send through
* Tcl_EvalObjEx, as that doesn't do ensemble processing, and we cannot go
* through Tcl_EvalObjv without the extra work to pre-find the command, as
|
| ︙ | ︙ | |||
1061 1062 1063 1064 1065 1066 1067 |
Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]);
} else {
Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
}
Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
/* TODO: overflow? */
Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc - offset, objv + offset);
| | | 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 |
Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]);
} else {
Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
}
Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
/* TODO: overflow? */
Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc - offset, objv + offset);
TclListObjGetElementsM(NULL, objPtr, &dummy, &objs);
result = Tcl_EvalObjv(interp, objc - cmdIndex, objs, TCL_EVAL_INVOKE);
if (isRoot) {
TclResetRewriteEnsemble(interp, 1);
}
Tcl_DecrRefCount(objPtr);
|
| ︙ | ︙ | |||
1088 1089 1090 1091 1092 1093 1094 | * messages are clearer. * * ---------------------------------------------------------------------- */ int TclOODefineObjCmd( | | | 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 |
* messages are clearer.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Namespace *nsPtr;
Object *oPtr;
int result;
|
| ︙ | ︙ | |||
1164 1165 1166 1167 1168 1169 1170 | * messages are clearer. * * ---------------------------------------------------------------------- */ int TclOOObjDefObjCmd( | | | 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 |
* messages are clearer.
*
* ----------------------------------------------------------------------
*/
int
TclOOObjDefObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Namespace *nsPtr;
Object *oPtr;
int result;
|
| ︙ | ︙ | |||
1233 1234 1235 1236 1237 1238 1239 | * dispatch so that error messages are clearer. * * ---------------------------------------------------------------------- */ int TclOODefineSelfObjCmd( | | | 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 |
* dispatch so that error messages are clearer.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineSelfObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Namespace *nsPtr;
Object *oPtr;
int result, isPrivate;
|
| ︙ | ︙ | |||
1304 1305 1306 1307 1308 1309 1310 | * command. * * ---------------------------------------------------------------------- */ int TclOODefineObjSelfObjCmd( | | | 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 |
* command.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineObjSelfObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr;
if (objc != 1) {
|
| ︙ | ︙ | |||
1411 1412 1413 1414 1415 1416 1417 | * command. * * ---------------------------------------------------------------------- */ int TclOODefineClassObjCmd( | | | 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 |
* command.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineClassObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr;
Class *clsPtr;
Foundation *fPtr = TclOOGetFoundation(interp);
|
| ︙ | ︙ | |||
1520 1521 1522 1523 1524 1525 1526 | * command. * * ---------------------------------------------------------------------- */ int TclOODefineConstructorObjCmd( | | | 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 |
* command.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineConstructorObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr;
Class *clsPtr;
Tcl_Method method;
|
| ︙ | ︙ | |||
1589 1590 1591 1592 1593 1594 1595 | * "oo::define" command. * * ---------------------------------------------------------------------- */ int TclOODefineDefnNsObjCmd( | | | 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 |
* "oo::define" command.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineDefnNsObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
static const char *kindList[] = {
"-class",
"-instance",
|
| ︙ | ︙ | |||
1731 1732 1733 1734 1735 1736 1737 | * command. * * ---------------------------------------------------------------------- */ int TclOODefineDestructorObjCmd( | | | 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 |
* command.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineDestructorObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr;
Class *clsPtr;
Tcl_Method method;
|
| ︙ | ︙ | |||
1841 1842 1843 1844 1845 1846 1847 |
if (isInstanceExport) {
if (!oPtr->methodsPtr) {
oPtr->methodsPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
| | | | 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 |
if (isInstanceExport) {
if (!oPtr->methodsPtr) {
oPtr->methodsPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, objv[i],
&isNew);
} else {
hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, objv[i],
&isNew);
}
if (isNew) {
mPtr = (Method *)Tcl_Alloc(sizeof(Method));
memset(mPtr, 0, sizeof(Method));
mPtr->refCount = 1;
|
| ︙ | ︙ | |||
2154 2155 2156 2157 2158 2159 2160 |
if (isInstanceUnexport) {
if (!oPtr->methodsPtr) {
oPtr->methodsPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
| | | | 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 |
if (isInstanceUnexport) {
if (!oPtr->methodsPtr) {
oPtr->methodsPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, objv[i],
&isNew);
} else {
hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, objv[i],
&isNew);
}
if (isNew) {
mPtr = (Method *)Tcl_Alloc(sizeof(Method));
memset(mPtr, 0, sizeof(Method));
mPtr->refCount = 1;
|
| ︙ | ︙ | |||
2282 2283 2284 2285 2286 2287 2288 |
for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) {
Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp,
(Tcl_Class) slotCls, slotInfoPtr->name, NULL, -1, NULL, 0);
if (slotObject == NULL) {
continue;
}
| | | | | 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 |
for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) {
Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp,
(Tcl_Class) slotCls, slotInfoPtr->name, NULL, -1, NULL, 0);
if (slotObject == NULL) {
continue;
}
TclNewInstanceMethod(fPtr->interp, slotObject, getName, 0,
&slotInfoPtr->getterType, NULL);
TclNewInstanceMethod(fPtr->interp, slotObject, setName, 0,
&slotInfoPtr->setterType, NULL);
if (slotInfoPtr->resolverType.callProc) {
TclNewInstanceMethod(fPtr->interp, slotObject, resolveName, 0,
&slotInfoPtr->resolverType, NULL);
}
}
Tcl_DecrRefCount(getName);
Tcl_DecrRefCount(setName);
Tcl_DecrRefCount(resolveName);
return TCL_OK;
|
| ︙ | ︙ | |||
2310 2311 2312 2313 2314 2315 2316 | * command. * * ---------------------------------------------------------------------- */ static int ClassFilterGet( | | | | | 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 |
* command.
*
* ----------------------------------------------------------------------
*/
static int
ClassFilterGet(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj, *filterObj;
size_t i;
if (Tcl_ObjectContextSkippedArgs(context) != (size_t)objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
|
| ︙ | ︙ | |||
2344 2345 2346 2347 2348 2349 2350 |
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassFilterSet(
| | | | | | 2346 2347 2348 2349 2350 2351 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 |
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassFilterSet(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
size_t filterc;
Tcl_Obj **filterv;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != (size_t)objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"filterList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (TclListObjGetElementsM(interp, objv[0], &filterc,
&filterv) != TCL_OK) {
return TCL_ERROR;
}
TclOOClassSetFilters(interp, oPtr->classPtr, filterc, filterv);
return TCL_OK;
}
|
| ︙ | ︙ | |||
2390 2391 2392 2393 2394 2395 2396 | * command. * * ---------------------------------------------------------------------- */ static int ClassMixinGet( | | | | | 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 |
* command.
*
* ----------------------------------------------------------------------
*/
static int
ClassMixinGet(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj;
Class *mixinPtr;
size_t i;
if (Tcl_ObjectContextSkippedArgs(context) != (size_t)objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
|
| ︙ | ︙ | |||
2427 2428 2429 2430 2431 2432 2433 |
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassMixinSet(
| | | | | | 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 |
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassMixinSet(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
size_t mixinc, i;
Tcl_Obj **mixinv;
Class **mixins;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != (size_t)objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"mixinList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (TclListObjGetElementsM(interp, objv[0], &mixinc,
&mixinv) != TCL_OK) {
return TCL_ERROR;
}
mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc);
for (i = 0; i < mixinc; i++) {
|
| ︙ | ︙ | |||
2496 2497 2498 2499 2500 2501 2502 | * command. * * ---------------------------------------------------------------------- */ static int ClassSuperGet( | | | | | 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 |
* command.
*
* ----------------------------------------------------------------------
*/
static int
ClassSuperGet(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj;
Class *superPtr;
size_t i;
if (Tcl_ObjectContextSkippedArgs(context) != (size_t)objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
|
| ︙ | ︙ | |||
2532 2533 2534 2535 2536 2537 2538 |
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassSuperSet(
| | | > | | | 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 |
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassSuperSet(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
size_t superc, j;
size_t i;
Tcl_Obj **superv;
Class **superclasses, *superPtr;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != (size_t)objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"superclassList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (oPtr == oPtr->fPtr->objectCls->thisPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not modify the superclass of the root object", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (TclListObjGetElementsM(interp, objv[0], &superc,
&superv) != TCL_OK) {
return TCL_ERROR;
}
/*
* Allocate some working space.
*/
|
| ︙ | ︙ | |||
2663 2664 2665 2666 2667 2668 2669 | * command. * * ---------------------------------------------------------------------- */ static int ClassVarsGet( | | | | | 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 |
* command.
*
* ----------------------------------------------------------------------
*/
static int
ClassVarsGet(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj;
size_t i;
if (Tcl_ObjectContextSkippedArgs(context) != (size_t)objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
|
| ︙ | ︙ | |||
2707 2708 2709 2710 2711 2712 2713 |
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassVarsSet(
| | > | < | | | 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 |
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassVarsSet(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
size_t i;
size_t varc;
Tcl_Obj **varv;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != (size_t)objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"filterList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (TclListObjGetElementsM(interp, objv[0], &varc,
&varv) != TCL_OK) {
return TCL_ERROR;
}
for (i = 0; i < varc; i++) {
const char *varName = TclGetString(varv[i]);
|
| ︙ | ︙ | |||
2778 2779 2780 2781 2782 2783 2784 | * command. * * ---------------------------------------------------------------------- */ static int ObjFilterGet( | | | | | | | | | 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 2841 |
* command.
*
* ----------------------------------------------------------------------
*/
static int
ObjFilterGet(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj, *filterObj;
size_t i;
if (Tcl_ObjectContextSkippedArgs(context) != (size_t)objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
} else if (oPtr == NULL) {
return TCL_ERROR;
}
TclNewObj(resultObj);
FOREACH(filterObj, oPtr->filters) {
Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ObjFilterSet(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
size_t filterc;
Tcl_Obj **filterv;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != (size_t)objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"filterList");
return TCL_ERROR;
} else if (oPtr == NULL) {
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (TclListObjGetElementsM(interp, objv[0], &filterc,
&filterv) != TCL_OK) {
return TCL_ERROR;
}
TclOOObjectSetFilters(oPtr, filterc, filterv);
return TCL_OK;
}
|
| ︙ | ︙ | |||
2846 2847 2848 2849 2850 2851 2852 | * command. * * ---------------------------------------------------------------------- */ static int ObjMixinGet( | | | | | > | < | | | 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 2910 2911 2912 2913 2914 2915 |
* command.
*
* ----------------------------------------------------------------------
*/
static int
ObjMixinGet(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj;
Class *mixinPtr;
size_t i;
if (Tcl_ObjectContextSkippedArgs(context) != (size_t)objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
} else if (oPtr == NULL) {
return TCL_ERROR;
}
TclNewObj(resultObj);
FOREACH(mixinPtr, oPtr->mixins) {
if (mixinPtr) {
Tcl_ListObjAppendElement(NULL, resultObj,
TclOOObjectName(interp, mixinPtr->thisPtr));
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ObjMixinSet(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
size_t i;
size_t mixinc;
Tcl_Obj **mixinv;
Class **mixins;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != (size_t)objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"mixinList");
return TCL_ERROR;
} else if (oPtr == NULL) {
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (TclListObjGetElementsM(interp, objv[0], &mixinc,
&mixinv) != TCL_OK) {
return TCL_ERROR;
}
mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc);
for (i = 0; i < mixinc; i++) {
|
| ︙ | ︙ | |||
2932 2933 2934 2935 2936 2937 2938 | * command. * * ---------------------------------------------------------------------- */ static int ObjVarsGet( | | | | | 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 |
* command.
*
* ----------------------------------------------------------------------
*/
static int
ObjVarsGet(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj;
size_t i;
if (Tcl_ObjectContextSkippedArgs(context) != (size_t)objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
} else if (oPtr == NULL) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2970 2971 2972 2973 2974 2975 2976 |
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ObjVarsSet(
| | | | | | 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 |
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ObjVarsSet(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
size_t varc, i;
Tcl_Obj **varv;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != (size_t)objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"variableList");
return TCL_ERROR;
} else if (oPtr == NULL) {
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (TclListObjGetElementsM(interp, objv[0], &varc,
&varv) != TCL_OK) {
return TCL_ERROR;
}
for (i = 0; i < varc; i++) {
const char *varName = TclGetString(varv[i]);
|
| ︙ | ︙ | |||
3035 3036 3037 3038 3039 3040 3041 | * names to their fully-qualified names if possible. * * ---------------------------------------------------------------------- */ static int ResolveClass( | | | 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 |
* names to their fully-qualified names if possible.
*
* ----------------------------------------------------------------------
*/
static int
ResolveClass(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
int idx = Tcl_ObjectContextSkippedArgs(context);
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
|
| ︙ | ︙ |
Changes to generic/tclOOInfo.c.
| ︙ | ︙ | |||
190 191 192 193 194 195 196 |
if (objc == 2) {
Tcl_SetObjResult(interp,
TclOOObjectName(interp, oPtr->selfCls->thisPtr));
return TCL_OK;
} else {
Class *mixinPtr, *o2clsPtr;
| | | 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 |
if (objc == 2) {
Tcl_SetObjResult(interp,
TclOOObjectName(interp, oPtr->selfCls->thisPtr));
return TCL_OK;
} else {
Class *mixinPtr, *o2clsPtr;
size_t i;
o2clsPtr = GetClassFromObj(interp, objv[2]);
if (o2clsPtr == NULL) {
return TCL_ERROR;
}
FOREACH(mixinPtr, oPtr->mixins) {
|
| ︙ | ︙ | |||
248 249 250 251 252 253 254 |
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!oPtr->methodsPtr) {
goto unknownMethod;
}
| | | 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 |
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!oPtr->methodsPtr) {
goto unknownMethod;
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]);
if (hPtr == NULL) {
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
303 304 305 306 307 308 309 |
static int
InfoObjectFiltersCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| | | 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 |
static int
InfoObjectFiltersCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
size_t i;
Tcl_Obj *filterObj, *resultObj;
Object *oPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "objName");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
359 360 361 362 363 364 365 |
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!oPtr->methodsPtr) {
goto unknownMethod;
}
| | | 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 |
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!oPtr->methodsPtr) {
goto unknownMethod;
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]);
if (hPtr == NULL) {
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
406 407 408 409 410 411 412 |
static const char *const categories[] = {
"class", "metaclass", "mixin", "object", "typeof", NULL
};
enum IsACats {
IsClass, IsMetaclass, IsMixin, IsObject, IsType
} idx;
Object *oPtr, *o2Ptr;
| | > | 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 |
static const char *const categories[] = {
"class", "metaclass", "mixin", "object", "typeof", NULL
};
enum IsACats {
IsClass, IsMetaclass, IsMixin, IsObject, IsType
} idx;
Object *oPtr, *o2Ptr;
int result = 0;
size_t i;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "category objName ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], categories, "category", 0,
&idx) != TCL_OK) {
|
| ︙ | ︙ | |||
655 656 657 658 659 660 661 |
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!oPtr->methodsPtr) {
goto unknownMethod;
}
| | | 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 |
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!oPtr->methodsPtr) {
goto unknownMethod;
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]);
if (hPtr == NULL) {
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
698 699 700 701 702 703 704 |
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *mixinPtr;
Object *oPtr;
Tcl_Obj *resultObj;
| | | 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 |
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *mixinPtr;
Object *oPtr;
Tcl_Obj *resultObj;
size_t i;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "objName");
return TCL_ERROR;
}
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
|
| ︙ | ︙ | |||
805 806 807 808 809 810 811 |
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
Tcl_Obj *resultObj;
| > | | 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 |
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
Tcl_Obj *resultObj;
size_t i;
int isPrivate = 0;
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?");
return TCL_ERROR;
}
if (objc == 3) {
if (strcmp("-private", TclGetString(objv[2])) != 0) {
|
| ︙ | ︙ | |||
993 994 995 996 997 998 999 |
Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
return TCL_ERROR;
}
clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
| | | 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 |
Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
return TCL_ERROR;
}
clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, objv[2]);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1141 1142 1143 1144 1145 1146 1147 |
static int
InfoClassFiltersCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| | | 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 |
static int
InfoClassFiltersCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
size_t i;
Tcl_Obj *filterObj, *resultObj;
Class *clsPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1191 1192 1193 1194 1195 1196 1197 |
Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
return TCL_ERROR;
}
clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
| | | 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 |
Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
return TCL_ERROR;
}
clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, objv[2]);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1232 1233 1234 1235 1236 1237 1238 |
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
Class *clsPtr;
| | | 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 |
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
Class *clsPtr;
size_t i;
const char *pattern = NULL;
Tcl_Obj *resultObj;
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1355 1356 1357 1358 1359 1360 1361 |
break;
}
}
TclNewObj(resultObj);
if (recurse) {
const char **names;
| | | 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 |
break;
}
}
TclNewObj(resultObj);
if (recurse) {
const char **names;
size_t i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names);
for (i=0 ; i<numNames ; i++) {
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(names[i], -1));
}
if (numNames > 0) {
Tcl_Free((void *)names);
|
| ︙ | ︙ | |||
1407 1408 1409 1410 1411 1412 1413 |
return TCL_ERROR;
}
clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
| | | 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 |
return TCL_ERROR;
}
clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, objv[2]);
if (hPtr == NULL) {
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
1448 1449 1450 1451 1452 1453 1454 |
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr, *mixinPtr;
Tcl_Obj *resultObj;
| | | 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 |
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr, *mixinPtr;
Tcl_Obj *resultObj;
size_t i;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
|
| ︙ | ︙ | |||
1490 1491 1492 1493 1494 1495 1496 |
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr, *subclassPtr;
Tcl_Obj *resultObj;
| | | 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 |
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr, *subclassPtr;
Tcl_Obj *resultObj;
size_t i;
const char *pattern = NULL;
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
return TCL_ERROR;
}
clsPtr = GetClassFromObj(interp, objv[1]);
|
| ︙ | ︙ | |||
1545 1546 1547 1548 1549 1550 1551 |
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr, *superPtr;
Tcl_Obj *resultObj;
| | | 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 |
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr, *superPtr;
Tcl_Obj *resultObj;
size_t i;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
|
| ︙ | ︙ | |||
1584 1585 1586 1587 1588 1589 1590 |
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr;
Tcl_Obj *resultObj;
| > | | 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 |
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr;
Tcl_Obj *resultObj;
size_t i;
int isPrivate = 0;
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?");
return TCL_ERROR;
}
if (objc == 3) {
if (strcmp("-private", TclGetString(objv[2])) != 0) {
|
| ︙ | ︙ |
Changes to generic/tclOOInt.h.
| ︙ | ︙ | |||
145 146 147 148 149 150 151 | * * The "num" field always counts the number of listType_t elements used in the * "list" field. When a "size" field exists, it describes how many elements * are present in the list; when absent, exactly "num" elements are present. */ #define LIST_STATIC(listType_t) \ | | | | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 |
*
* The "num" field always counts the number of listType_t elements used in the
* "list" field. When a "size" field exists, it describes how many elements
* are present in the list; when absent, exactly "num" elements are present.
*/
#define LIST_STATIC(listType_t) \
struct { size_t num; listType_t *list; }
#define LIST_DYNAMIC(listType_t) \
struct { size_t num, size; listType_t *list; }
/*
* These types are needed in function arguments.
*/
typedef LIST_STATIC(Tcl_Obj *) VariableNameList;
typedef LIST_STATIC(PrivateVariableMapping) PrivateVariableList;
|
| ︙ | ︙ | |||
231 232 233 234 235 236 237 | * no methods, mixins, or filters. */ #define ROOT_CLASS 0x8000 /* Flag to say that this object is the root * class of classes, and should be treated * specially during teardown (and in a few * other spots). */ #define FORCE_UNKNOWN 0x10000 /* States that we are *really* looking up the * unknown method handler at that point. */ | > > > > | < < < < | 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 |
* no methods, mixins, or filters. */
#define ROOT_CLASS 0x8000 /* Flag to say that this object is the root
* class of classes, and should be treated
* specially during teardown (and in a few
* other spots). */
#define FORCE_UNKNOWN 0x10000 /* States that we are *really* looking up the
* unknown method handler at that point. */
#define DONT_DELETE 0x20000 /* Inhibit deletion of this object. Used
* during fundamental object type mutation to
* make sure that the object actually survives
* to the end of the operation. */
#define HAS_PRIVATE_METHODS 0x40000
/* Object/class has (or had) private methods,
* and so shouldn't be cached so
* aggressively. */
/*
* And the definition of a class. Note that every class also has an associated
* object, through which it is manipulated.
*/
typedef struct Class {
|
| ︙ | ︙ | |||
443 444 445 446 447 448 449 | /* *---------------------------------------------------------------- * Commands relating to OO support. *---------------------------------------------------------------- */ MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); | | < < | < < | < | | < < | < < | < < | < < | < < | < < | < < | < < | < < | < | | < < | < < | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < | < < | < < | < < | < < | < < | < < | < < | < < | < < > > > > > > > > > > > | | | 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 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 |
/*
*----------------------------------------------------------------
* Commands relating to OO support.
*----------------------------------------------------------------
*/
MODULE_SCOPE int TclOOInit(Tcl_Interp *interp);
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOOObjDefObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineConstructorObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDefnNsObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDeleteMethodObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDestructorObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineExportObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineForwardObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineMethodObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineRenameMethodObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineUnexportObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineClassObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineSelfObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefineObjSelfObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOODefinePrivateObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOOUnknownDefinition;
MODULE_SCOPE Tcl_ObjCmdProc TclOOCopyObjectCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOONextObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOONextToObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOOSelfObjCmd;
/*
* Method implementations (in tclOOBasic.c).
*/
MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_Constructor;
MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_Create;
MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_CreateNs;
MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_New;
MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_Destroy;
MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_Eval;
MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_LinkVar;
MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_Unknown;
MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_VarName;
/*
* Private definitions, some of which perhaps ought to be exposed properly or
* maybe just put in the internal stubs table.
*/
MODULE_SCOPE void TclOOAddToInstances(Object *oPtr, Class *clsPtr);
MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr);
MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr);
MODULE_SCOPE Class * TclOOAllocClass(Tcl_Interp *interp,
Object *useThisObj);
MODULE_SCOPE int TclMethodIsType(Tcl_Method method,
const Tcl_MethodType *typePtr,
void **clientDataPtr);
MODULE_SCOPE Tcl_Method TclNewInstanceMethod(Tcl_Interp *interp,
Tcl_Object object, Tcl_Obj *nameObj,
int flags, const Tcl_MethodType *typePtr,
void *clientData);
MODULE_SCOPE Tcl_Method TclNewMethod(Tcl_Interp *interp, Tcl_Class cls,
Tcl_Obj *nameObj, int flags,
const Tcl_MethodType *typePtr,
void *clientData);
MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp,
Tcl_Class cls, const char *nameStr,
const char *nsNameStr, size_t objc,
Tcl_Obj *const *objv, size_t skip,
Tcl_Object *objectPtr);
MODULE_SCOPE Object * TclNewObjectInstanceCommon(Tcl_Interp *interp,
Class *classPtr,
const char *nameStr,
const char *nsNameStr);
MODULE_SCOPE int TclOODecrRefCount(Object *oPtr);
MODULE_SCOPE int TclOOObjectDestroyed(Object *oPtr);
|
| ︙ | ︙ | |||
600 601 602 603 604 605 606 | Tcl_Interp *interp, Object *oPtr, int forClass); MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr, Tcl_Obj *methodNameObj, int flags); MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr); MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr); MODULE_SCOPE Tcl_Obj * TclOOGetMethodBody(Method *mPtr); | | | | | 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 | Tcl_Interp *interp, Object *oPtr, int forClass); MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr, Tcl_Obj *methodNameObj, int flags); MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr); MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr); MODULE_SCOPE Tcl_Obj * TclOOGetMethodBody(Method *mPtr); MODULE_SCOPE size_t TclOOGetSortedClassMethodList(Class *clsPtr, int flags, const char ***stringsPtr); MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, Object *contextObj, Class *contextCls, int flags, const char ***stringsPtr); MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); MODULE_SCOPE void TclOOInitInfo(Tcl_Interp *interp); MODULE_SCOPE int TclOOInvokeContext(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, size_t objc, Tcl_Obj *const *objv, size_t skip); MODULE_SCOPE void TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr, const DeclaredClassMethod *dcm); MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr); MODULE_SCOPE void TclOOReleaseClassContents(Tcl_Interp *interp, Object *oPtr); MODULE_SCOPE int TclOORemoveFromInstances(Object *oPtr, Class *clsPtr); MODULE_SCOPE int TclOORemoveFromMixins(Class *mixinPtr, Object *oPtr); |
| ︙ | ︙ | |||
645 646 647 648 649 650 651 | */ #define AddRef(ptr) ((ptr)->refCount++) /* * A convenience macro for iterating through the lists used in the internal * memory management of objects. | | | | 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 |
*/
#define AddRef(ptr) ((ptr)->refCount++)
/*
* A convenience macro for iterating through the lists used in the internal
* memory management of objects.
* REQUIRES DECLARATION: size_t i;
*/
#define FOREACH(var,ary) \
for(i=0 ; i<(ary).num; i++) if ((ary).list[i] == NULL) { \
continue; \
} else if ((var) = (ary).list[i], 1)
/*
* A variation where the array is an array of structs. There's no issue with
* possible NULLs; every element of the array will be iterated over and the
* varable set to a pointer to each of those elements in turn.
* REQUIRES DECLARATION: size_t i;
*/
#define FOREACH_STRUCT(var,ary) \
for(i=0 ; var=&((ary).list[i]), i<(ary).num; i++)
/*
* Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS
|
| ︙ | ︙ |
Changes to generic/tclOOIntDecls.h.
| ︙ | ︙ | |||
38 39 40 41 42 43 44 | /* 4 */ TCLAPI Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 5 */ TCLAPI int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, | | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | /* 4 */ TCLAPI Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 5 */ TCLAPI int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, size_t objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 6 */ TCLAPI int TclOOIsReachable(Class *targetPtr, Class *startPtr); /* 7 */ TCLAPI Method * TclOONewForwardMethod(Tcl_Interp *interp, Class *clsPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); |
| ︙ | ︙ | |||
71 72 73 74 75 76 77 | ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 11 */ TCLAPI int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, | | | | | | | | | | | | | | 71 72 73 74 75 76 77 78 79 80 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 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 |
ProcErrorProc *errProc, void *clientData,
Tcl_Obj *nameObj, Tcl_Obj *argsObj,
Tcl_Obj *bodyObj, int flags,
void **internalTokenPtr);
/* 11 */
TCLAPI int TclOOInvokeObject(Tcl_Interp *interp,
Tcl_Object object, Tcl_Class startCls,
int publicPrivate, size_t objc,
Tcl_Obj *const *objv);
/* 12 */
TCLAPI void TclOOObjectSetFilters(Object *oPtr,
size_t numFilters, Tcl_Obj *const *filters);
/* 13 */
TCLAPI void TclOOClassSetFilters(Tcl_Interp *interp,
Class *classPtr, size_t numFilters,
Tcl_Obj *const *filters);
/* 14 */
TCLAPI void TclOOObjectSetMixins(Object *oPtr, size_t numMixins,
Class *const *mixins);
/* 15 */
TCLAPI void TclOOClassSetMixins(Tcl_Interp *interp,
Class *classPtr, size_t numMixins,
Class *const *mixins);
typedef struct TclOOIntStubs {
int magic;
void *hooks;
Tcl_Object (*tclOOGetDefineCmdContext) (Tcl_Interp *interp); /* 0 */
Tcl_Method (*tclOOMakeProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, void *clientData, Proc **procPtrPtr); /* 1 */
Tcl_Method (*tclOOMakeProcMethod) (Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, void *clientData, Proc **procPtrPtr); /* 2 */
Method * (*tclOONewProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 3 */
Method * (*tclOONewProcMethod) (Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 4 */
int (*tclOOObjectCmdCore) (Object *oPtr, Tcl_Interp *interp, size_t objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 5 */
int (*tclOOIsReachable) (Class *targetPtr, Class *startPtr); /* 6 */
Method * (*tclOONewForwardMethod) (Tcl_Interp *interp, Class *clsPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 7 */
Method * (*tclOONewForwardInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 8 */
Tcl_Method (*tclOONewProcInstanceMethodEx) (Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 9 */
Tcl_Method (*tclOONewProcMethodEx) (Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */
int (*tclOOInvokeObject) (Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, size_t objc, Tcl_Obj *const *objv); /* 11 */
void (*tclOOObjectSetFilters) (Object *oPtr, size_t numFilters, Tcl_Obj *const *filters); /* 12 */
void (*tclOOClassSetFilters) (Tcl_Interp *interp, Class *classPtr, size_t numFilters, Tcl_Obj *const *filters); /* 13 */
void (*tclOOObjectSetMixins) (Object *oPtr, size_t numMixins, Class *const *mixins); /* 14 */
void (*tclOOClassSetMixins) (Tcl_Interp *interp, Class *classPtr, size_t numMixins, Class *const *mixins); /* 15 */
} TclOOIntStubs;
extern const TclOOIntStubs *tclOOIntStubsPtr;
#ifdef __cplusplus
}
#endif
|
| ︙ | ︙ |
Changes to generic/tclOOMethod.c.
| ︙ | ︙ | |||
122 123 124 125 126 127 128 | * * Attach a method to an object instance. * * ---------------------------------------------------------------------- */ Tcl_Method | | | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 |
*
* Attach a method to an object instance.
*
* ----------------------------------------------------------------------
*/
Tcl_Method
TclNewInstanceMethod(
TCL_UNUSED(Tcl_Interp *),
Tcl_Object object, /* The object that has the method attached to
* it. */
Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so,
* up to caller to manage storage (e.g., when
* it is a constructor or destructor). */
int flags, /* Whether this is a public method. */
|
| ︙ | ︙ | |||
153 154 155 156 157 158 159 |
goto populate;
}
if (!oPtr->methodsPtr) {
oPtr->methodsPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
| | | 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 |
goto populate;
}
if (!oPtr->methodsPtr) {
oPtr->methodsPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, nameObj, &isNew);
if (isNew) {
mPtr = (Method *)Tcl_Alloc(sizeof(Method));
mPtr->namePtr = nameObj;
mPtr->refCount = 1;
Tcl_IncrRefCount(nameObj);
Tcl_SetHashValue(hPtr, mPtr);
} else {
|
| ︙ | ︙ | |||
183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 |
if (flags & TRUE_PRIVATE_METHOD) {
oPtr->flags |= HAS_PRIVATE_METHODS;
}
}
oPtr->epoch++;
return (Tcl_Method) mPtr;
}
/*
* ----------------------------------------------------------------------
*
* Tcl_NewMethod --
*
* Attach a method to a class.
*
* ----------------------------------------------------------------------
*/
Tcl_Method
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 219 220 221 222 223 224 225 226 227 228 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 |
if (flags & TRUE_PRIVATE_METHOD) {
oPtr->flags |= HAS_PRIVATE_METHODS;
}
}
oPtr->epoch++;
return (Tcl_Method) mPtr;
}
Tcl_Method
Tcl_NewInstanceMethod(
TCL_UNUSED(Tcl_Interp *),
Tcl_Object object, /* The object that has the method attached to
* it. */
Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so,
* up to caller to manage storage (e.g., when
* it is a constructor or destructor). */
int flags, /* Whether this is a public method. */
const Tcl_MethodType *typePtr,
/* The type of method this is, which defines
* how to invoke, delete and clone the
* method. */
void *clientData) /* Some data associated with the particular
* method to be created. */
{
if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_NewInstanceMethod");
}
return TclNewInstanceMethod(NULL, object, nameObj, flags,
(const Tcl_MethodType *)typePtr, clientData);
}
Tcl_Method
Tcl_NewInstanceMethod2(
TCL_UNUSED(Tcl_Interp *),
Tcl_Object object, /* The object that has the method attached to
* it. */
Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so,
* up to caller to manage storage (e.g., when
* it is a constructor or destructor). */
int flags, /* Whether this is a public method. */
const Tcl_MethodType2 *typePtr,
/* The type of method this is, which defines
* how to invoke, delete and clone the
* method. */
void *clientData) /* Some data associated with the particular
* method to be created. */
{
if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_NewInstanceMethod2");
}
return TclNewInstanceMethod(NULL, object, nameObj, flags,
(const Tcl_MethodType *)typePtr, clientData);
}
/*
* ----------------------------------------------------------------------
*
* Tcl_NewMethod --
*
* Attach a method to a class.
*
* ----------------------------------------------------------------------
*/
Tcl_Method
TclNewMethod(
TCL_UNUSED(Tcl_Interp *),
Tcl_Class cls, /* The class to attach the method to. */
Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g.,
* for constructors or destructors); if so, up
* to caller to manage storage. */
int flags, /* Whether this is a public method. */
const Tcl_MethodType *typePtr,
|
| ︙ | ︙ | |||
220 221 222 223 224 225 226 |
if (nameObj == NULL) {
mPtr = (Method *)Tcl_Alloc(sizeof(Method));
mPtr->namePtr = NULL;
mPtr->refCount = 1;
goto populate;
}
| | | 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 |
if (nameObj == NULL) {
mPtr = (Method *)Tcl_Alloc(sizeof(Method));
mPtr->namePtr = NULL;
mPtr->refCount = 1;
goto populate;
}
hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, nameObj,&isNew);
if (isNew) {
mPtr = (Method *)Tcl_Alloc(sizeof(Method));
mPtr->refCount = 1;
mPtr->namePtr = nameObj;
Tcl_IncrRefCount(nameObj);
Tcl_SetHashValue(hPtr, mPtr);
} else {
|
| ︙ | ︙ | |||
251 252 253 254 255 256 257 258 259 260 261 262 263 264 |
if (flags & TRUE_PRIVATE_METHOD) {
clsPtr->flags |= HAS_PRIVATE_METHODS;
}
}
return (Tcl_Method) mPtr;
}
/*
* ----------------------------------------------------------------------
*
* TclOODelMethodRef --
*
* How to delete a method.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
if (flags & TRUE_PRIVATE_METHOD) {
clsPtr->flags |= HAS_PRIVATE_METHODS;
}
}
return (Tcl_Method) mPtr;
}
Tcl_Method
Tcl_NewMethod(
TCL_UNUSED(Tcl_Interp *),
Tcl_Class cls, /* The class to attach the method to. */
Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g.,
* for constructors or destructors); if so, up
* to caller to manage storage. */
int flags, /* Whether this is a public method. */
const Tcl_MethodType *typePtr,
/* The type of method this is, which defines
* how to invoke, delete and clone the
* method. */
void *clientData) /* Some data associated with the particular
* method to be created. */
{
if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_NewMethod");
}
return TclNewMethod(NULL, cls, nameObj, flags, typePtr, clientData);
}
Tcl_Method
Tcl_NewMethod2(
TCL_UNUSED(Tcl_Interp *),
Tcl_Class cls, /* The class to attach the method to. */
Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g.,
* for constructors or destructors); if so, up
* to caller to manage storage. */
int flags, /* Whether this is a public method. */
const Tcl_MethodType2 *typePtr,
/* The type of method this is, which defines
* how to invoke, delete and clone the
* method. */
void *clientData) /* Some data associated with the particular
* method to be created. */
{
if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_NewMethod2");
}
return TclNewMethod(NULL, cls, nameObj, flags, (const Tcl_MethodType *)typePtr, clientData);
}
/*
* ----------------------------------------------------------------------
*
* TclOODelMethodRef --
*
* How to delete a method.
|
| ︙ | ︙ | |||
300 301 302 303 304 305 306 |
const DeclaredClassMethod *dcm)
/* Name of the method, whether it is public,
* and the function to implement it. */
{
Tcl_Obj *namePtr = Tcl_NewStringObj(dcm->name, -1);
Tcl_IncrRefCount(namePtr);
| | | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 |
const DeclaredClassMethod *dcm)
/* Name of the method, whether it is public,
* and the function to implement it. */
{
Tcl_Obj *namePtr = Tcl_NewStringObj(dcm->name, -1);
Tcl_IncrRefCount(namePtr);
TclNewMethod(interp, (Tcl_Class) clsPtr, namePtr,
(dcm->isPublic ? PUBLIC_METHOD : 0), &dcm->definition, NULL);
Tcl_DecrRefCount(namePtr);
}
/*
* ----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
331 332 333 334 335 336 337 |
Tcl_Obj *bodyObj, /* The body of the method, which must not be
* NULL. */
ProcedureMethod **pmPtrPtr) /* Place to write pointer to procedure method
* structure to allow for deeper tuning of the
* structure's contents. NULL if caller is not
* interested. */
{
| | | | 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 |
Tcl_Obj *bodyObj, /* The body of the method, which must not be
* NULL. */
ProcedureMethod **pmPtrPtr) /* Place to write pointer to procedure method
* structure to allow for deeper tuning of the
* structure's contents. NULL if caller is not
* interested. */
{
size_t argsLen;
ProcedureMethod *pmPtr;
Tcl_Method method;
if (TclListObjLengthM(interp, argsObj, &argsLen) != TCL_OK) {
return NULL;
}
pmPtr = (ProcedureMethod *)Tcl_Alloc(sizeof(ProcedureMethod));
memset(pmPtr, 0, sizeof(ProcedureMethod));
pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
pmPtr->flags = flags & USE_DECLARER_NS;
pmPtr->refCount = 1;
|
| ︙ | ︙ | |||
383 384 385 386 387 388 389 |
Tcl_Obj *bodyObj, /* The body of the method, which must not be
* NULL. */
ProcedureMethod **pmPtrPtr) /* Place to write pointer to procedure method
* structure to allow for deeper tuning of the
* structure's contents. NULL if caller is not
* interested. */
{
| | | | | | 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 |
Tcl_Obj *bodyObj, /* The body of the method, which must not be
* NULL. */
ProcedureMethod **pmPtrPtr) /* Place to write pointer to procedure method
* structure to allow for deeper tuning of the
* structure's contents. NULL if caller is not
* interested. */
{
size_t argsLen; /* TCL_INDEX_NONE => delete argsObj before exit */
ProcedureMethod *pmPtr;
const char *procName;
Tcl_Method method;
if (argsObj == NULL) {
argsLen = TCL_INDEX_NONE;
TclNewObj(argsObj);
Tcl_IncrRefCount(argsObj);
procName = "<destructor>";
} else if (TclListObjLengthM(interp, argsObj, &argsLen) != TCL_OK) {
return NULL;
} else {
procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));
}
pmPtr = (ProcedureMethod *)Tcl_Alloc(sizeof(ProcedureMethod));
memset(pmPtr, 0, sizeof(ProcedureMethod));
pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
pmPtr->flags = flags & USE_DECLARER_NS;
pmPtr->refCount = 1;
method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj, procName,
argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);
if (argsLen == TCL_INDEX_NONE) {
Tcl_DecrRefCount(argsObj);
}
if (method == NULL) {
Tcl_Free(pmPtr);
} else if (pmPtrPtr != NULL) {
*pmPtrPtr = pmPtr;
}
|
| ︙ | ︙ | |||
511 512 513 514 515 516 517 | cfPtr->data.eval.path = context.data.eval.path; Tcl_IncrRefCount(cfPtr->data.eval.path); cfPtr->cmd = NULL; cfPtr->len = 0; hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, | | | | 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 |
cfPtr->data.eval.path = context.data.eval.path;
Tcl_IncrRefCount(cfPtr->data.eval.path);
cfPtr->cmd = NULL;
cfPtr->len = 0;
hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
procPtr, &isNew);
Tcl_SetHashValue(hPtr, cfPtr);
}
/*
* 'context' is going out of scope; account for the reference that
* it's holding to the path name.
*/
Tcl_DecrRefCount(context.data.eval.path);
context.data.eval.path = NULL;
}
}
return TclNewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags,
typePtr, clientData);
}
/*
* ----------------------------------------------------------------------
*
* TclOOMakeProcMethod --
|
| ︙ | ︙ | |||
624 625 626 627 628 629 630 | cfPtr->data.eval.path = context.data.eval.path; Tcl_IncrRefCount(cfPtr->data.eval.path); cfPtr->cmd = NULL; cfPtr->len = 0; hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, | | | | 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 |
cfPtr->data.eval.path = context.data.eval.path;
Tcl_IncrRefCount(cfPtr->data.eval.path);
cfPtr->cmd = NULL;
cfPtr->len = 0;
hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
procPtr, &isNew);
Tcl_SetHashValue(hPtr, cfPtr);
}
/*
* 'context' is going out of scope; account for the reference that
* it's holding to the path name.
*/
Tcl_DecrRefCount(context.data.eval.path);
context.data.eval.path = NULL;
}
}
return TclNewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, typePtr,
clientData);
}
/*
* ----------------------------------------------------------------------
*
* InvokeProcedureMethod, PushMethodCallFrame --
|
| ︙ | ︙ | |||
983 984 985 986 987 988 989 |
OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr;
Interp *iPtr = (Interp *) interp;
CallFrame *framePtr = iPtr->varFramePtr;
CallContext *contextPtr;
Tcl_Obj *variableObj;
PrivateVariableMapping *privateVar;
Tcl_HashEntry *hPtr;
| | | | 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 |
OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr;
Interp *iPtr = (Interp *) interp;
CallFrame *framePtr = iPtr->varFramePtr;
CallContext *contextPtr;
Tcl_Obj *variableObj;
PrivateVariableMapping *privateVar;
Tcl_HashEntry *hPtr;
int isNew, cacheIt;
size_t i, varLen, len;
const char *match, *varName;
/*
* Check that the variable is being requested in a context that is also a
* method call; if not (i.e. we're evaluating in the object's namespace or
* in a procedure of that namespace) then we do nothing.
*/
|
| ︙ | ︙ | |||
1058 1059 1060 1061 1062 1063 1064 |
/*
* It is a variable we want to resolve, so resolve it.
*/
gotMatch:
hPtr = Tcl_CreateHashEntry(TclVarTable(contextPtr->oPtr->namespacePtr),
| | | 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 |
/*
* It is a variable we want to resolve, so resolve it.
*/
gotMatch:
hPtr = Tcl_CreateHashEntry(TclVarTable(contextPtr->oPtr->namespacePtr),
variableObj, &isNew);
if (isNew) {
TclSetVarNamespaceVar((Var *) TclVarHashGetValue(hPtr));
}
if (cacheIt) {
infoPtr->cachedObjectVar = TclVarHashGetValue(hPtr);
/*
|
| ︙ | ︙ | |||
1098 1099 1100 1101 1102 1103 1104 |
Tcl_Free(infoPtr);
}
static int
ProcedureMethodCompiledVarResolver(
TCL_UNUSED(Tcl_Interp *),
const char *varName,
| | | 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 |
Tcl_Free(infoPtr);
}
static int
ProcedureMethodCompiledVarResolver(
TCL_UNUSED(Tcl_Interp *),
const char *varName,
size_t length,
TCL_UNUSED(Tcl_Namespace *),
Tcl_ResolvedVarInfo **rPtrPtr)
{
OOResVarInfo *infoPtr;
Tcl_Obj *variableObj = Tcl_NewStringObj(varName, length);
/*
|
| ︙ | ︙ | |||
1383 1384 1385 1386 1387 1388 1389 |
Tcl_Interp *interp, /* Interpreter for error reporting. */
Object *oPtr, /* The object to attach the method to. */
int flags, /* Whether the method is public or not. */
Tcl_Obj *nameObj, /* The name of the method. */
Tcl_Obj *prefixObj) /* List of arguments that form the command
* prefix to forward to. */
{
| | | | | 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 |
Tcl_Interp *interp, /* Interpreter for error reporting. */
Object *oPtr, /* The object to attach the method to. */
int flags, /* Whether the method is public or not. */
Tcl_Obj *nameObj, /* The name of the method. */
Tcl_Obj *prefixObj) /* List of arguments that form the command
* prefix to forward to. */
{
size_t prefixLen;
ForwardMethod *fmPtr;
if (TclListObjLengthM(interp, prefixObj, &prefixLen) != TCL_OK) {
return NULL;
}
if (prefixLen < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method forward prefix must be non-empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
return NULL;
}
fmPtr = (ForwardMethod *)Tcl_Alloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_IncrRefCount(prefixObj);
return (Method *) TclNewInstanceMethod(interp, (Tcl_Object) oPtr,
nameObj, flags, &fwdMethodType, fmPtr);
}
/*
* ----------------------------------------------------------------------
*
* TclOONewForwardMethod --
|
| ︙ | ︙ | |||
1422 1423 1424 1425 1426 1427 1428 |
Tcl_Interp *interp, /* Interpreter for error reporting. */
Class *clsPtr, /* The class to attach the method to. */
int flags, /* Whether the method is public or not. */
Tcl_Obj *nameObj, /* The name of the method. */
Tcl_Obj *prefixObj) /* List of arguments that form the command
* prefix to forward to. */
{
| | | | | 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 |
Tcl_Interp *interp, /* Interpreter for error reporting. */
Class *clsPtr, /* The class to attach the method to. */
int flags, /* Whether the method is public or not. */
Tcl_Obj *nameObj, /* The name of the method. */
Tcl_Obj *prefixObj) /* List of arguments that form the command
* prefix to forward to. */
{
size_t prefixLen;
ForwardMethod *fmPtr;
if (TclListObjLengthM(interp, prefixObj, &prefixLen) != TCL_OK) {
return NULL;
}
if (prefixLen < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method forward prefix must be non-empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
return NULL;
}
fmPtr = (ForwardMethod *)Tcl_Alloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_IncrRefCount(prefixObj);
return (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr, nameObj,
flags, &fwdMethodType, fmPtr);
}
/*
* ----------------------------------------------------------------------
*
* InvokeForwardMethod --
|
| ︙ | ︙ | |||
1464 1465 1466 1467 1468 1469 1470 |
Tcl_ObjectContext context, /* The method calling context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments as actually seen. */
{
CallContext *contextPtr = (CallContext *) context;
ForwardMethod *fmPtr = (ForwardMethod *)clientData;
Tcl_Obj **argObjs, **prefixObjs;
| | | | | 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 |
Tcl_ObjectContext context, /* The method calling context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments as actually seen. */
{
CallContext *contextPtr = (CallContext *) context;
ForwardMethod *fmPtr = (ForwardMethod *)clientData;
Tcl_Obj **argObjs, **prefixObjs;
size_t numPrefixes, skip = contextPtr->skip;
int len;
/*
* 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.
*/
TclListObjGetElementsM(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs);
argObjs = InitEnsembleRewrite(interp, objc, objv, skip,
numPrefixes, prefixObjs, &len);
Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL);
/*
* NOTE: The combination of direct set of iPtr->lookupNsPtr and the use
* of the TCL_EVAL_NOERR flag results in an evaluation configuration
* very much like TCL_EVAL_INVOKE.
|
| ︙ | ︙ | |||
1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 |
Tcl_Obj *
Tcl_MethodName(
Tcl_Method method)
{
return ((Method *) method)->namePtr;
}
int
Tcl_MethodIsType(
Tcl_Method method,
const Tcl_MethodType *typePtr,
void **clientDataPtr)
{
Method *mPtr = (Method *) method;
if (mPtr->typePtr == typePtr) {
if (clientDataPtr != NULL) {
*clientDataPtr = mPtr->clientData;
}
return 1;
}
return 0;
}
int
Tcl_MethodIsPublic(
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 |
Tcl_Obj *
Tcl_MethodName(
Tcl_Method method)
{
return ((Method *) method)->namePtr;
}
int
TclMethodIsType(
Tcl_Method method,
const Tcl_MethodType *typePtr,
void **clientDataPtr)
{
Method *mPtr = (Method *) method;
if (mPtr->typePtr == typePtr) {
if (clientDataPtr != NULL) {
*clientDataPtr = mPtr->clientData;
}
return 1;
}
return 0;
}
int
Tcl_MethodIsType(
Tcl_Method method,
const Tcl_MethodType *typePtr,
void **clientDataPtr)
{
Method *mPtr = (Method *) method;
if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_MethodIsType");
}
if (mPtr->typePtr == typePtr) {
if (clientDataPtr != NULL) {
*clientDataPtr = mPtr->clientData;
}
return 1;
}
return 0;
}
int
Tcl_MethodIsType2(
Tcl_Method method,
const Tcl_MethodType2 *typePtr,
void **clientDataPtr)
{
Method *mPtr = (Method *) method;
if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_MethodIsType2");
}
if (mPtr->typePtr == (const Tcl_MethodType *)typePtr) {
if (clientDataPtr != NULL) {
*clientDataPtr = mPtr->clientData;
}
return 1;
}
return 0;
}
int
Tcl_MethodIsPublic(
|
| ︙ | ︙ |
Changes to generic/tclOOStubInit.c.
| ︙ | ︙ | |||
72 73 74 75 76 77 78 79 80 81 |
Tcl_ObjectSetMethodNameMapper, /* 25 */
Tcl_ClassSetConstructor, /* 26 */
Tcl_ClassSetDestructor, /* 27 */
Tcl_GetObjectName, /* 28 */
Tcl_MethodIsPrivate, /* 29 */
Tcl_GetClassOfObject, /* 30 */
Tcl_GetObjectClassName, /* 31 */
};
/* !END!: Do not edit above this line. */
| > > > | 72 73 74 75 76 77 78 79 80 81 82 83 84 |
Tcl_ObjectSetMethodNameMapper, /* 25 */
Tcl_ClassSetConstructor, /* 26 */
Tcl_ClassSetDestructor, /* 27 */
Tcl_GetObjectName, /* 28 */
Tcl_MethodIsPrivate, /* 29 */
Tcl_GetClassOfObject, /* 30 */
Tcl_GetObjectClassName, /* 31 */
Tcl_MethodIsType2, /* 32 */
Tcl_NewInstanceMethod2, /* 33 */
Tcl_NewMethod2, /* 34 */
};
/* !END!: Do not edit above this line. */
|
Changes to generic/tclObj.c.
| ︙ | ︙ | |||
521 522 523 524 525 526 527 |
* TIP #280
*----------------------------------------------------------------------
*/
ContLineLoc *
TclContinuationsEnter(
Tcl_Obj *objPtr,
| | | 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 |
* TIP #280
*----------------------------------------------------------------------
*/
ContLineLoc *
TclContinuationsEnter(
Tcl_Obj *objPtr,
size_t num,
int *loc)
{
int newEntry;
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry);
ContLineLoc *clLocPtr = (ContLineLoc *)Tcl_Alloc(offsetof(ContLineLoc, loc) + (num + 1U) *sizeof(int));
|
| ︙ | ︙ | |||
831 832 833 834 835 836 837 |
Tcl_Interp *interp, /* Interpreter used for error reporting. */
Tcl_Obj *objPtr) /* Points to the Tcl object onto which the
* name of each registered type is appended as
* a list element. */
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
| | | | 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 |
Tcl_Interp *interp, /* Interpreter used for error reporting. */
Tcl_Obj *objPtr) /* Points to the Tcl object onto which the
* name of each registered type is appended as
* a list element. */
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
size_t numElems;
/*
* Get the test for a valid list out of the way first.
*/
if (TclListObjLengthM(interp, objPtr, &numElems) != TCL_OK) {
return TCL_ERROR;
}
/*
* Type names are NUL-terminated, not counted strings. This code relies on
* that.
*/
|
| ︙ | ︙ | |||
1273 1274 1275 1276 1277 1278 1279 |
Tcl_HashEntry *hPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
tablePtr = tsdPtr->objThreadMap;
if (!tablePtr) {
Tcl_Panic("TclFreeObj: object table not initialized");
}
| | | 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 |
Tcl_HashEntry *hPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
tablePtr = tsdPtr->objThreadMap;
if (!tablePtr) {
Tcl_Panic("TclFreeObj: object table not initialized");
}
hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
if (hPtr) {
/*
* As the Tcl_Obj is going to be deleted we remove the entry.
*/
ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr);
|
| ︙ | ︙ | |||
1671 1672 1673 1674 1675 1676 1677 |
|| objPtr->bytes[objPtr->length] != '\0') {
Tcl_Panic("UpdateStringProc for type '%s' "
"failed to create a valid string rep",
objPtr->typePtr->name);
}
}
if (lengthPtr != NULL) {
| | > > > > | 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 |
|| objPtr->bytes[objPtr->length] != '\0') {
Tcl_Panic("UpdateStringProc for type '%s' "
"failed to create a valid string rep",
objPtr->typePtr->name);
}
}
if (lengthPtr != NULL) {
if (objPtr->length > INT_MAX) {
Tcl_Panic("Tcl_GetStringFromObj with 'int' lengthPtr"
"cannot handle such long strings. Please use 'size_t'");
}
*lengthPtr = (int)objPtr->length;
}
return objPtr->bytes;
}
#undef Tcl_GetStringFromObj
char *
Tcl_GetStringFromObj(
|
| ︙ | ︙ | |||
2488 2489 2490 2491 2492 2493 2494 |
if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) {
return TCL_ERROR;
}
if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < INT_MIN))) {
if (interp != NULL) {
const char *s =
| | | 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 |
if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) {
return TCL_ERROR;
}
if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < INT_MIN))) {
if (interp != NULL) {
const char *s =
"integer value too large to represent";
Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
}
return TCL_ERROR;
}
*intPtr = (int) l;
return TCL_OK;
|
| ︙ | ︙ |
Changes to generic/tclOptimize.c.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 | static void TrimUnreachable(CompileEnv *envPtr); /* * Helper macros. */ #define DefineTargetAddress(tablePtr, address) \ | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
static void TrimUnreachable(CompileEnv *envPtr);
/*
* Helper macros.
*/
#define DefineTargetAddress(tablePtr, address) \
((void) Tcl_CreateHashEntry((tablePtr), (address), &isNew))
#define IsTargetAddress(tablePtr, address) \
(Tcl_FindHashEntry((tablePtr), (void *) (address)) != NULL)
#define AddrLength(address) \
(tclInstructionTable[*(unsigned char *)(address)].numBytes)
#define InstLength(instruction) \
(tclInstructionTable[UCHAR(instruction)].numBytes)
|
| ︙ | ︙ | |||
50 51 52 53 54 55 56 |
static void
LocateTargetAddresses(
CompileEnv *envPtr,
Tcl_HashTable *tablePtr)
{
unsigned char *currentInstPtr, *targetInstPtr;
| | > | 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 |
static void
LocateTargetAddresses(
CompileEnv *envPtr,
Tcl_HashTable *tablePtr)
{
unsigned char *currentInstPtr, *targetInstPtr;
int isNew;
size_t i;
Tcl_HashEntry *hPtr;
Tcl_HashSearch hSearch;
Tcl_InitHashTable(tablePtr, TCL_ONE_WORD_KEYS);
/*
* The starts of commands represent target addresses.
|
| ︙ | ︙ | |||
129 130 131 132 133 134 135 |
if (rangePtr->type == CATCH_EXCEPTION_RANGE) {
targetInstPtr = envPtr->codeStart + rangePtr->catchOffset;
DefineTargetAddress(tablePtr, targetInstPtr);
} else {
targetInstPtr = envPtr->codeStart + rangePtr->breakOffset;
DefineTargetAddress(tablePtr, targetInstPtr);
| | | 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 |
if (rangePtr->type == CATCH_EXCEPTION_RANGE) {
targetInstPtr = envPtr->codeStart + rangePtr->catchOffset;
DefineTargetAddress(tablePtr, targetInstPtr);
} else {
targetInstPtr = envPtr->codeStart + rangePtr->breakOffset;
DefineTargetAddress(tablePtr, targetInstPtr);
if (rangePtr->continueOffset != TCL_INDEX_NONE) {
targetInstPtr = envPtr->codeStart + rangePtr->continueOffset;
DefineTargetAddress(tablePtr, targetInstPtr);
}
}
}
}
|
| ︙ | ︙ |
Changes to generic/tclParse.c.
| ︙ | ︙ | |||
340 341 342 343 344 345 346 |
* Check whether the braces contained the word expansion prefix
* {*}
*/
expPtr = &parsePtr->tokenPtr[expIdx];
if ((0 == expandWord)
/* Haven't seen prefix already */
| | | 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 |
* Check whether the braces contained the word expansion prefix
* {*}
*/
expPtr = &parsePtr->tokenPtr[expIdx];
if ((0 == expandWord)
/* Haven't seen prefix already */
&& (expIdx + 1 == (int)parsePtr->numTokens)
/* Only one token */
&& (((1 == expPtr->size)
/* Same length as prefix */
&& (expPtr->start[0] == '*')))
/* Is the prefix */
&& (numBytes > 0) && (0 == ParseWhiteSpace(termPtr,
numBytes, &parsePtr->incomplete, &type))
|
| ︙ | ︙ | |||
375 376 377 378 379 380 381 | /* * Finish filling in the token for the word and check for the special * case of a word consisting of a single range of literal text. */ tokenPtr = &parsePtr->tokenPtr[wordIndex]; tokenPtr->size = src - tokenPtr->start; | | | 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 |
/*
* Finish filling in the token for the word and check for the special
* case of a word consisting of a single range of literal text.
*/
tokenPtr = &parsePtr->tokenPtr[wordIndex];
tokenPtr->size = src - tokenPtr->start;
tokenPtr->numComponents = (int)parsePtr->numTokens - (wordIndex + 1);
if (expandWord) {
size_t i;
int isLiteral = 1;
/*
* When a command includes a word that is an expanded literal; for
* example, {*}{1 2 3}, the parser performs that expansion
|
| ︙ | ︙ | |||
467 468 469 470 471 472 473 | /* * Recalculate the number of Tcl_Tokens needed to store * tokens representing the expanded list. */ const char *listStart; int growthNeeded = wordIndex + 2*elemCount | | | 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 |
/*
* Recalculate the number of Tcl_Tokens needed to store
* tokens representing the expanded list.
*/
const char *listStart;
int growthNeeded = wordIndex + 2*elemCount
- (int)parsePtr->numTokens;
parsePtr->numWords += elemCount - 1;
if (growthNeeded > 0) {
TclGrowParseTokenArray(parsePtr, growthNeeded);
tokenPtr = &parsePtr->tokenPtr[wordIndex];
}
parsePtr->numTokens = wordIndex + 2*elemCount;
|
| ︙ | ︙ | |||
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 |
case 'u':
count += ParseHex(p+1, (numBytes > 5) ? 4 : numBytes-2, &result);
if (count == 2) {
/*
* No hexdigits -> This is just "u".
*/
result = 'u';
} else if (((result & 0xFC00) == 0xD800) && (count == 6)
&& (p[5] == '\\') && (p[6] == 'u') && (numBytes >= 10)) {
/* If high surrogate is immediately followed by a low surrogate
* escape, combine them into one character. */
int low;
int count2 = ParseHex(p+7, 4, &low);
if ((count2 == 4) && ((low & 0xFC00) == 0xDC00)) {
result = ((result & 0x3FF)<<10 | (low & 0x3FF)) + 0x10000;
count += count2 + 2;
}
}
break;
case 'U':
count += ParseHex(p+1, (numBytes > 9) ? 8 : numBytes-2, &result);
if (count == 2) {
/*
* No hexdigits -> This is just "U".
*/
result = 'U';
| > > < < < | 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 |
case 'u':
count += ParseHex(p+1, (numBytes > 5) ? 4 : numBytes-2, &result);
if (count == 2) {
/*
* No hexdigits -> This is just "u".
*/
result = 'u';
#if TCL_UTF_MAX < 4
} else if (((result & 0xFC00) == 0xD800) && (count == 6)
&& (p[5] == '\\') && (p[6] == 'u') && (numBytes >= 10)) {
/* If high surrogate is immediately followed by a low surrogate
* escape, combine them into one character. */
int low;
int count2 = ParseHex(p+7, 4, &low);
if ((count2 == 4) && ((low & 0xFC00) == 0xDC00)) {
result = ((result & 0x3FF)<<10 | (low & 0x3FF)) + 0x10000;
count += count2 + 2;
}
#endif
}
break;
case 'U':
count += ParseHex(p+1, (numBytes > 9) ? 8 : numBytes-2, &result);
if (count == 2) {
/*
* No hexdigits -> This is just "U".
*/
result = 'U';
}
break;
case '\n':
count--;
do {
p++;
count++;
|
| ︙ | ︙ | |||
950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 |
}
done:
if (readPtr != NULL) {
*readPtr = count;
}
count = Tcl_UniCharToUtf(result, dst);
if ((result >= 0xD800) && (count < 3)) {
/* Special case for handling high surrogates. */
count += Tcl_UniCharToUtf(-1, dst + count);
}
return count;
}
/*
*----------------------------------------------------------------------
*
* ParseComment --
| > > | 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 |
}
done:
if (readPtr != NULL) {
*readPtr = count;
}
count = Tcl_UniCharToUtf(result, dst);
#if TCL_UTF_MAX < 4
if ((result >= 0xD800) && (count < 3)) {
/* Special case for handling high surrogates. */
count += Tcl_UniCharToUtf(-1, dst + count);
}
#endif
return count;
}
/*
*----------------------------------------------------------------------
*
* ParseComment --
|
| ︙ | ︙ | |||
1226 1227 1228 1229 1230 1231 1232 |
/*
* Note: backslash-newline is special in that it is treated
* the same as a space character would be. This means that it
* could terminate the token.
*/
if (mask & TYPE_SPACE) {
| | | | 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 |
/*
* Note: backslash-newline is special in that it is treated
* the same as a space character would be. This means that it
* could terminate the token.
*/
if (mask & TYPE_SPACE) {
if ((int)parsePtr->numTokens == originalTokens) {
goto finishToken;
}
break;
}
}
tokenPtr->type = TCL_TOKEN_BS;
parsePtr->numTokens++;
src += tokenPtr->size;
numBytes -= tokenPtr->size;
} else if (*src == 0) {
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->size = 1;
parsePtr->numTokens++;
src++;
numBytes--;
} else {
Tcl_Panic("ParseTokens encountered unknown character");
}
}
if ((int)parsePtr->numTokens == originalTokens) {
/*
* There was nothing in this range of text. Add an empty token for the
* empty range, so that there is always at least one token added.
*/
TclGrowParseTokenArray(parsePtr, 1);
tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
|
| ︙ | ︙ | |||
1675 1676 1677 1678 1679 1680 1681 |
* {} - finish emitting zero-sized token
*
* The last case ensures that there is a token (even if empty)
* that describes the braced string.
*/
if ((src != tokenPtr->start)
| | | 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 |
* {} - finish emitting zero-sized token
*
* The last case ensures that there is a token (even if empty)
* that describes the braced string.
*/
if ((src != tokenPtr->start)
|| ((int)parsePtr->numTokens == startIndex)) {
tokenPtr->size = (src - tokenPtr->start);
parsePtr->numTokens++;
}
if (termPtr != NULL) {
*termPtr = src+1;
}
return TCL_OK;
|
| ︙ | ︙ | |||
2088 2089 2090 2091 2092 2093 2094 |
int
TclSubstTokens(
Tcl_Interp *interp, /* Interpreter in which to lookup variables,
* execute nested commands, and report
* errors. */
Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to
* evaluate and concatenate. */
| | | | 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 |
int
TclSubstTokens(
Tcl_Interp *interp, /* Interpreter in which to lookup variables,
* execute nested commands, and report
* errors. */
Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to
* evaluate and concatenate. */
size_t count, /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
int *tokensLeftPtr, /* If not NULL, points to memory where an
* integer representing the number of tokens
* left to be substituted will be written */
size_t line, /* The line the script starts on. */
int *clNextOuter, /* Information about an outer context for */
const char *outerScript) /* continuation line data. This is set by
* EvalEx() to properly handle [...]-nested
* commands. The 'outerScript' refers to the
* most-outer script containing the embedded
* command, which is refered to by 'script'.
* The 'clNextOuter' refers to the current
|
| ︙ | ︙ | |||
2115 2116 2117 2118 2119 2120 2121 |
* command. See Tcl_EvalEx and TclEvalObjEx
* for the places generating arguments for
* which this is true. */
{
Tcl_Obj *result;
int code = TCL_OK;
#define NUM_STATIC_POS 20
| | > | 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 |
* command. See Tcl_EvalEx and TclEvalObjEx
* for the places generating arguments for
* which this is true. */
{
Tcl_Obj *result;
int code = TCL_OK;
#define NUM_STATIC_POS 20
int isLiteral;
size_t i, maxNumCL, numCL, adjust;
int *clPosition = NULL;
Interp *iPtr = (Interp *) interp;
int inFile = iPtr->evalFlags & TCL_EVAL_FILE;
/*
* Each pass through this loop will substitute one token, and its
* components, if any. The only thing tricky here is that we go to some
|
| ︙ | ︙ | |||
2220 2221 2222 2223 2224 2225 2226 |
iPtr->numLevels++;
code = TclInterpReady(interp);
if (code == TCL_OK) {
/*
* Test cases: info-30.{6,8,9}
*/
| | | 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 |
iPtr->numLevels++;
code = TclInterpReady(interp);
if (code == TCL_OK) {
/*
* Test cases: info-30.{6,8,9}
*/
size_t theline;
TclAdvanceContinuations(&line, &clNextOuter,
tokenPtr->start - outerScript);
theline = line + adjust;
code = TclEvalEx(interp, tokenPtr->start+1, tokenPtr->size-2,
0, theline, clNextOuter, outerScript);
|
| ︙ | ︙ | |||
2445 2446 2447 2448 2449 2450 2451 |
*----------------------------------------------------------------------
*/
int
Tcl_CommandComplete(
const char *script) /* Script to check. */
{
| | | 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 |
*----------------------------------------------------------------------
*/
int
Tcl_CommandComplete(
const char *script) /* Script to check. */
{
return CommandComplete(script, strlen(script));
}
/*
*----------------------------------------------------------------------
*
* TclObjCommandComplete --
*
|
| ︙ | ︙ |
Changes to generic/tclPathObj.c.
| ︙ | ︙ | |||
21 22 23 24 25 26 27 | static Tcl_Obj * AppendPath(Tcl_Obj *head, Tcl_Obj *tail); static void DupFsPathInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeFsPathInternalRep(Tcl_Obj *pathPtr); static void UpdateStringOfFsPath(Tcl_Obj *pathPtr); static int SetFsPathFromAny(Tcl_Interp *interp, Tcl_Obj *pathPtr); | | | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | static Tcl_Obj * AppendPath(Tcl_Obj *head, Tcl_Obj *tail); static void DupFsPathInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeFsPathInternalRep(Tcl_Obj *pathPtr); static void UpdateStringOfFsPath(Tcl_Obj *pathPtr); static int SetFsPathFromAny(Tcl_Interp *interp, Tcl_Obj *pathPtr); static size_t FindSplitPos(const char *path, int separator); static int IsSeparatorOrNull(int ch); static Tcl_Obj * GetExtension(Tcl_Obj *pathPtr); static int MakePathFromNormalized(Tcl_Interp *interp, Tcl_Obj *pathPtr); /* * Define the 'path' object type, which Tcl uses to represent file paths |
| ︙ | ︙ | |||
472 473 474 475 476 477 478 |
*----------------------------------------------------------------------
*/
Tcl_PathType
TclFSGetPathType(
Tcl_Obj *pathPtr,
const Tcl_Filesystem **filesystemPtrPtr,
| | | 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 |
*----------------------------------------------------------------------
*/
Tcl_PathType
TclFSGetPathType(
Tcl_Obj *pathPtr,
const Tcl_Filesystem **filesystemPtrPtr,
size_t *driveNameLengthPtr)
{
FsPath *fsPathPtr;
if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) {
return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr,
NULL);
}
|
| ︙ | ︙ | |||
536 537 538 539 540 541 542 | * None. * *--------------------------------------------------------------------------- */ Tcl_Obj * TclPathPart( | | | 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 |
* None.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclPathPart(
TCL_UNUSED(Tcl_Interp *), /* Used for error reporting */
Tcl_Obj *pathPtr, /* Path to take dirname of */
Tcl_PathPart portion) /* Requested portion of name */
{
if (TclHasInternalRep(pathPtr, &fsPathType)) {
FsPath *fsPathPtr = PATHOBJ(pathPtr);
if (PATHFLAGS(pathPtr) != 0) {
|
| ︙ | ︙ | |||
662 663 664 665 666 667 668 |
/* Relative path */
goto standardPath;
} else {
/* Absolute path */
goto standardPath;
}
} else {
| | | 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 |
/* Relative path */
goto standardPath;
} else {
/* Absolute path */
goto standardPath;
}
} else {
size_t splitElements;
Tcl_Obj *splitPtr, *resultPtr;
standardPath:
resultPtr = NULL;
if (portion == TCL_PATH_EXTENSION) {
return GetExtension(pathPtr);
} else if (portion == TCL_PATH_ROOT) {
|
| ︙ | ︙ | |||
695 696 697 698 699 700 701 | * Tcl_FSSplitPath in the handling of home directories; * Tcl_FSSplitPath preserves the "~", but this code computes the * actual full path name, if we had just a single component. */ splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements); Tcl_IncrRefCount(splitPtr); | < < < < < < < < < < | | 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 |
* Tcl_FSSplitPath in the handling of home directories;
* Tcl_FSSplitPath preserves the "~", but this code computes the
* actual full path name, if we had just a single component.
*/
splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements);
Tcl_IncrRefCount(splitPtr);
if (portion == TCL_PATH_TAIL) {
/*
* Return the last component, unless it is the only component, and
* it is the root of an absolute path.
*/
if ((splitElements > 0) && ((splitElements > 1) ||
(Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE))) {
|
| ︙ | ︙ | |||
800 801 802 803 804 805 806 |
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSJoinPath(
Tcl_Obj *listObj, /* Path elements to join, may have a zero
* reference count. */
| | | | | | | | < < | 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 |
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSJoinPath(
Tcl_Obj *listObj, /* Path elements to join, may have a zero
* reference count. */
size_t elements) /* Number of elements to use (-1 = all) */
{
Tcl_Obj *res;
size_t objc;
Tcl_Obj **objv;
if (TclListObjLengthM(NULL, listObj, &objc) != TCL_OK) {
return NULL;
}
elements = ((elements != TCL_INDEX_NONE) && (elements <= objc)) ? elements : objc;
TclListObjGetElementsM(NULL, listObj, &objc, &objv);
res = TclJoinPath(elements, objv, 0);
return res;
}
Tcl_Obj *
TclJoinPath(
size_t elements, /* Number of elements to use */
Tcl_Obj * const objv[], /* Path elements to join */
int forceRelative) /* If non-zero, assume all more paths are
* relative (e. g. simple normalization) */
{
Tcl_Obj *res = NULL;
size_t i;
const Tcl_Filesystem *fsPtr = NULL;
if (elements == 0) {
TclNewObj(res);
return res;
}
assert ( elements > 0 );
|
| ︙ | ︙ | |||
930 931 932 933 934 935 936 |
}
}
}
assert ( res == NULL );
for (i = 0; i < elements; i++) {
| | | 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 |
}
}
}
assert ( res == NULL );
for (i = 0; i < elements; i++) {
size_t driveNameLength;
size_t strEltLen, length;
Tcl_PathType type;
char *strElt, *ptr;
Tcl_Obj *driveName = NULL;
Tcl_Obj *elt = objv[i];
strElt = Tcl_GetStringFromObj(elt, &strEltLen);
|
| ︙ | ︙ | |||
1036 1037 1038 1039 1040 1041 1042 |
noQuickReturn:
if (res == NULL) {
TclNewObj(res);
}
ptr = Tcl_GetStringFromObj(res, &length);
| | < < < < < < < < < < | | 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 |
noQuickReturn:
if (res == NULL) {
TclNewObj(res);
}
ptr = Tcl_GetStringFromObj(res, &length);
/*
* A NULL value for fsPtr at this stage basically means we're trying
* to join a relative path onto something which is also relative (or
* empty). There's nothing particularly wrong with that.
*/
if (*strElt == '\0') {
continue;
}
|
| ︙ | ︙ | |||
1244 1245 1246 1247 1248 1249 1250 |
size_t len)
{
FsPath *fsPathPtr;
Tcl_Obj *pathPtr;
const char *p;
int state = 0, count = 0;
| > > > | < < < < < < < | 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 |
size_t len)
{
FsPath *fsPathPtr;
Tcl_Obj *pathPtr;
const char *p;
int state = 0, count = 0;
/*
* This comment is kept from the days of tilde expansion because
* it is illustrative of a more general problem.
* [Bug 2806250] - this is only a partial solution of the problem.
* The PATHFLAGS != 0 representation assumes in many places that
* the "tail" part stored in the normPathPtr field is itself a
* relative path. Strings that begin with "~" are not relative paths,
* so we must prevent their storage in the normPathPtr field.
*
* More generally we ought to be testing "addStrRep" for any value
* that is not a relative path, but in an unconstrained VFS world
* that could be just about anything, and testing could be expensive.
* Since this routine plays a big role in [glob], anything that slows
* it down would be unwelcome. For now, continue the risk of further
* bugs when some Tcl_Filesystem uses otherwise relative path strings
* as absolute path strings. Sensible Tcl_Filesystems will avoid
* that by mounting on path prefixes like foo:// which cannot be the
* name of a file or directory read from a native [glob] operation.
*/
TclNewObj(pathPtr);
fsPathPtr = (FsPath *)Tcl_Alloc(sizeof(FsPath));
/*
* Set up the path.
*/
|
| ︙ | ︙ | |||
2181 2182 2183 2184 2185 2186 2187 | *--------------------------------------------------------------------------- * * SetFsPathFromAny -- * * Attempt to convert the internal representation of pathPtr to * fsPathType. * | < < < < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 |
*---------------------------------------------------------------------------
*
* SetFsPathFromAny --
*
* Attempt to convert the internal representation of pathPtr to
* fsPathType.
*
* Results:
* Standard Tcl error code.
*
* Side effects:
* The old representation may be freed, and new memory allocated.
*
*---------------------------------------------------------------------------
*/
static int
SetFsPathFromAny(
TCL_UNUSED(Tcl_Interp *), /* Used for error reporting if not NULL. */
Tcl_Obj *pathPtr) /* The object to convert. */
{
size_t len;
FsPath *fsPathPtr;
Tcl_Obj *transPtr;
if (TclHasInternalRep(pathPtr, &fsPathType)) {
return TCL_OK;
}
/*
* First step is to translate the filename. This is similar to
* Tcl_TranslateFilename, but shouldn't convert everything to windows
* backslashes on that platform. The current implementation of this piece
* is a slightly optimised version of the various Tilde/Split/Join stuff
* to avoid multiple split/join operations.
*
* We remove any trailing directory separator.
*
* However, the split/join routines are quite complex, and one has to make
* sure not to break anything on Unix or Win (fCmd.test, fileName.test and
* cmdAH.test exercise most of the code).
*/
Tcl_GetStringFromObj(pathPtr, &len); /* TODO: Is this needed? */
transPtr = TclJoinPath(1, &pathPtr, 1);
/*
* Now we have a translated filename in 'transPtr'. This will have forward
* slashes on Windows, and will not contain any ~user sequences.
*/
fsPathPtr = (FsPath *)Tcl_Alloc(sizeof(FsPath));
|
| ︙ | ︙ | |||
2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 |
/*
* Path is of correct type, or is of non-zero length, so we accept it.
*/
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 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 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 |
/*
* Path is of correct type, or is of non-zero length, so we accept it.
*/
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* MakeTildeRelativePath --
*
* Returns a path relative to the home directory of a user.
* Note there is a difference between not specifying a user and
* explicitly specifying the current user. This mimics Tcl8's tilde
* expansion.
*
* The subPath argument is joined to the expanded home directory
* as in Tcl_JoinPath. This means if it is not relative, it will
* returned as the result with the home directory only checked
* for user name validity.
*
* Results:
* Returns TCL_OK on success with home directory path in *dsPtr
* and TCL_ERROR on failure with error message in interp if non-NULL.
*
*----------------------------------------------------------------------
*/
int
MakeTildeRelativePath(
Tcl_Interp *interp, /* May be NULL. Only used for error messages */
const char *user, /* User name. NULL -> current user */
const char *subPath, /* Rest of path. May be NULL */
Tcl_DString *dsPtr) /* Output. Is initialized by the function. Must be
freed on success */
{
const char *dir;
Tcl_DString dirString;
Tcl_DStringInit(dsPtr);
Tcl_DStringInit(&dirString);
if (user == NULL || user[0] == 0) {
/* No user name specified -> current user */
dir = TclGetEnv("HOME", &dirString);
if (dir == NULL) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"couldn't find HOME environment variable to"
" expand path", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH",
"HOMELESS", NULL);
}
return TCL_ERROR;
}
} else {
/* User name specified - ~user */
dir = TclpGetUserHome(user, &dirString);
if (dir == NULL) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"user \"%s\" doesn't exist", user));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER",
NULL);
}
return TCL_ERROR;
}
}
if (subPath) {
const char *parts[2];
parts[0] = dir;
parts[1] = subPath;
Tcl_JoinPath(2, parts, dsPtr);
} else {
Tcl_JoinPath(1, &dir, dsPtr);
}
Tcl_DStringFree(&dirString);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclGetHomeDirObj --
*
* Wrapper around MakeTildeRelativePath. See that function.
*
* Results:
* Returns a Tcl_Obj containing the home directory of a user
* or NULL on failure with error message in interp if non-NULL.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclGetHomeDirObj(
Tcl_Interp *interp, /* May be NULL. Only used for error messages */
const char *user) /* User name. NULL -> current user */
{
Tcl_DString dirString;
if (MakeTildeRelativePath(interp, user, NULL, &dirString) != TCL_OK) {
return NULL;
}
return TclDStringToObj(&dirString);
}
/*
*----------------------------------------------------------------------
*
* TclResolveTildePath --
*
* If the passed path is begins with a tilde, does tilde resolution
* and returns a Tcl_Obj containing the resolved path. If the tilde
* component cannot be resolved, returns NULL. If the path does not
* begin with a tilde, returns as is.
*
* Results:
* Returns a Tcl_Obj with resolved path. This may be a new Tcl_Obj
* with ref count 0 or that pathObj that was passed in without its
* ref count modified.
* Returns NULL if the path begins with a ~ that cannot be resolved
* and stores an error message in interp if non-NULL.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclResolveTildePath(
Tcl_Interp *interp, /* May be NULL. Only used for error messages */
Tcl_Obj *pathObj)
{
const char *path;
size_t len;
size_t split;
Tcl_DString resolvedPath;
path = Tcl_GetStringFromObj(pathObj, &len);
if (path[0] != '~') {
return pathObj;
}
/*
* We have multiple cases '~/foo/bar...', '~user/foo/bar...', etc.
* split becomes value 1 for '~/...' as well as for '~'. Note on
* Windows FindSplitPos will implicitly check for '\' as separator
* in addition to what is passed.
*/
split = FindSplitPos(path, '/');
if (split == 1) {
/* No user name specified -> current user */
if (MakeTildeRelativePath(
interp, NULL, path[1] ? 2 + path : NULL, &resolvedPath)
!= TCL_OK) {
return NULL;
}
} else {
/* User name specified - ~user */
const char *expandedUser;
Tcl_DString userName;
Tcl_DStringInit(&userName);
Tcl_DStringAppend(&userName, path+1, split-1);
expandedUser = Tcl_DStringValue(&userName);
/* path[split] is / or \0 */
if (MakeTildeRelativePath(interp,
expandedUser,
path[split] ? &path[split+1] : NULL,
&resolvedPath)
!= TCL_OK) {
Tcl_DStringFree(&userName);
return NULL;
}
Tcl_DStringFree(&userName);
}
return TclDStringToObj(&resolvedPath);
}
/*
*----------------------------------------------------------------------
*
* TclResolveTildePathList --
*
* Given a Tcl_Obj that is a list of paths, returns a Tcl_Obj containing
* the paths with any ~-prefixed paths resolved.
*
* Empty strings and ~-prefixed paths that cannot be resolved are
* removed from the returned list.
*
* The trailing components of the path are returned verbatim. No
* processing is done on them. Moreover, no assumptions should be
* made about the separators in the returned path. They may be /
* or native. Appropriate path manipulations functions should be
* used by caller if desired.
*
* Results:
* Returns a Tcl_Obj with resolved paths. This may be a new Tcl_Obj with
* reference count 0 or the original passed-in Tcl_Obj if no paths needed
* resolution. A NULL is returned if the passed in value is not a list
* or was NULL.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclResolveTildePathList(
Tcl_Obj *pathsObj)
{
Tcl_Obj **objv;
size_t objc;
size_t i;
Tcl_Obj *resolvedPaths;
const char *path;
if (pathsObj == NULL) {
return NULL;
}
if (Tcl_ListObjGetElements(NULL, pathsObj, &objc, &objv) != TCL_OK) {
return NULL; /* Not a list */
}
/*
* Figure out if any paths need resolving to avoid unnecessary allocations.
*/
for (i = 0; i < objc; ++i) {
path = Tcl_GetString(objv[i]);
if (path[0] == '~') {
break; /* At least one path needs resolution */
}
}
if (i == objc) {
return pathsObj; /* No paths needed to be resolved */
}
resolvedPaths = Tcl_NewListObj(objc, NULL);
for (i = 0; i < objc; ++i) {
Tcl_Obj *resolvedPath;
path = Tcl_GetString(objv[i]);
if (path[0] == 0) {
continue; /* Skip empty strings */
}
resolvedPath = TclResolveTildePath(NULL, objv[i]);
if (resolvedPath) {
/* Paths that cannot be resolved are skipped */
Tcl_ListObjAppendElement(NULL, resolvedPaths, resolvedPath);
}
}
return resolvedPaths;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclPipe.c.
| ︙ | ︙ | |||
175 176 177 178 179 180 181 | * None. * *---------------------------------------------------------------------- */ void Tcl_DetachPids( | | | | 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 |
* None.
*
*----------------------------------------------------------------------
*/
void
Tcl_DetachPids(
size_t numPids, /* Number of pids to detach: gives size of
* array pointed to by pidPtr. */
Tcl_Pid *pidPtr) /* Array of pids to detach. */
{
Detached *detPtr;
size_t i;
Tcl_MutexLock(&pipeMutex);
for (i = 0; i < numPids; i++) {
detPtr = (Detached *)Tcl_Alloc(sizeof(Detached));
detPtr->pid = pidPtr[i];
detPtr->nextPtr = detList;
detList = detPtr;
|
| ︙ | ︙ | |||
429 430 431 432 433 434 435 |
* redirection then the file will still be
* created but it will never get any data. */
{
Tcl_Pid *pidPtr = NULL; /* Points to malloc-ed array holding all the
* pids of child processes. */
size_t numPids; /* Actual number of processes that exist at
* *pidPtr right now. */
| | | 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 |
* redirection then the file will still be
* created but it will never get any data. */
{
Tcl_Pid *pidPtr = NULL; /* Points to malloc-ed array holding all the
* pids of child processes. */
size_t numPids; /* Actual number of processes that exist at
* *pidPtr right now. */
size_t cmdCount; /* Count of number of distinct commands found
* in argc/argv. */
const char *inputLiteral = NULL;
/* If non-null, then this points to a string
* containing input data (specified via <<) to
* be piped to the first process in the
* pipeline. */
TclFile inputFile = NULL; /* If != NULL, gives file to use as input for
|
| ︙ | ︙ | |||
1017 1018 1019 1020 1021 1022 1023 |
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_OpenCommandChannel(
Tcl_Interp *interp, /* Interpreter for error reporting. Can NOT be
* NULL. */
| | | | | | 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 |
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_OpenCommandChannel(
Tcl_Interp *interp, /* Interpreter for error reporting. Can NOT be
* NULL. */
size_t argc, /* How many arguments. */
const char **argv, /* Array of arguments for command pipe. */
int flags) /* Or'ed combination of TCL_STDIN, TCL_STDOUT,
* TCL_STDERR, and TCL_ENFORCE_MODE. */
{
TclFile *inPipePtr, *outPipePtr, *errFilePtr;
TclFile inPipe, outPipe, errFile;
size_t numPids;
Tcl_Pid *pidPtr = NULL;
Tcl_Channel channel;
inPipe = outPipe = errFile = NULL;
inPipePtr = (flags & TCL_STDIN) ? &inPipe : NULL;
outPipePtr = (flags & TCL_STDOUT) ? &outPipe : NULL;
errFilePtr = (flags & TCL_STDERR) ? &errFile : NULL;
numPids = TclCreatePipeline(interp, argc, argv, &pidPtr, inPipePtr,
outPipePtr, errFilePtr);
if (numPids == TCL_INDEX_NONE) {
goto error;
}
/*
* Verify that the pipes that were created satisfy the readable/writable
* constraints.
*/
|
| ︙ | ︙ | |||
1077 1078 1079 1080 1081 1082 1083 |
"pipe for command could not be created", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", NULL);
goto error;
}
return channel;
error:
| | | 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 |
"pipe for command could not be created", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", NULL);
goto error;
}
return channel;
error:
if (pidPtr) {
Tcl_DetachPids(numPids, pidPtr);
Tcl_Free(pidPtr);
}
if (inPipe != NULL) {
TclpCloseFile(inPipe);
}
if (outPipe != NULL) {
|
| ︙ | ︙ |
Changes to generic/tclPkg.c.
| ︙ | ︙ | |||
422 423 424 425 426 427 428 |
}
int
Tcl_PkgRequireProc(
Tcl_Interp *interp, /* Interpreter in which package is now
* available. */
const char *name, /* Name of desired package. */
| | | 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 |
}
int
Tcl_PkgRequireProc(
Tcl_Interp *interp, /* Interpreter in which package is now
* available. */
const char *name, /* Name of desired package. */
size_t reqc, /* Requirements constraining the desired
* version. */
Tcl_Obj *const reqv[], /* 0 means to use the latest version
* available. */
void *clientDataPtr)
{
RequireProcArgs args;
|
| ︙ | ︙ | |||
1059 1060 1061 1062 1063 1064 1065 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRPackageObjCmd, clientData, objc, objv);
}
int
TclNRPackageObjCmd(
| | | > | 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRPackageObjCmd, clientData, objc, objv);
}
int
TclNRPackageObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const pkgOptions[] = {
"files", "forget", "ifneeded", "names", "prefer",
"present", "provide", "require", "unknown", "vcompare",
"versions", "vsatisfies", NULL
};
enum pkgOptionsEnum {
PKG_FILES, PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER,
PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE,
PKG_VERSIONS, PKG_VSATISFIES
} optionIndex;
Interp *iPtr = (Interp *) interp;
int exact, satisfies;
size_t i, newobjc;
PkgAvail *availPtr, *prevPtr;
Package *pkgPtr;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Tcl_HashTable *tablePtr;
const char *version;
const char *argv2, *argv3, *argv4;
|
| ︙ | ︙ | |||
1119 1120 1121 1122 1123 1124 1125 |
break;
}
case PKG_FORGET: {
const char *keyString;
PkgFiles *pkgFiles = (PkgFiles *)
Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
| | | 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 |
break;
}
case PKG_FORGET: {
const char *keyString;
PkgFiles *pkgFiles = (PkgFiles *)
Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
for (i = 2; i < (size_t)objc; i++) {
keyString = TclGetString(objv[i]);
if (pkgFiles) {
hPtr = Tcl_FindHashEntry(&pkgFiles->table, keyString);
if (hPtr) {
Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
Tcl_DeleteHashEntry(hPtr);
Tcl_DecrRefCount(obj);
|
| ︙ | ︙ | |||
1357 1358 1359 1360 1361 1362 1363 | version = NULL; argv3 = TclGetString(objv[3]); Tcl_IncrRefCount(objv[3]); objvListPtr = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(objvListPtr); Tcl_ListObjAppendElement(interp, objvListPtr, ov); | | | 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 | version = NULL; argv3 = TclGetString(objv[3]); Tcl_IncrRefCount(objv[3]); objvListPtr = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(objvListPtr); Tcl_ListObjAppendElement(interp, objvListPtr, ov); TclListObjGetElementsM(interp, objvListPtr, &newobjc, &newObjvPtr); Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL,NULL); Tcl_NRAddCallback(interp, PkgRequireCore, (void *) argv3, INT2PTR(newobjc), newObjvPtr, NULL); return TCL_OK; |
| ︙ | ︙ | |||
1384 1385 1386 1387 1388 1389 1390 | * Tcl_Obj structures may have come from another interpreter, * so duplicate them. */ Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i])); } | | | 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 | * Tcl_Obj structures may have come from another interpreter, * so duplicate them. */ Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i])); } TclListObjGetElementsM(interp, objvListPtr, &newobjc, &newObjvPtr); Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL,NULL); Tcl_NRAddCallback(interp, PkgRequireCore, (void *) argv2, INT2PTR(newobjc), newObjvPtr, NULL); return TCL_OK; } |
| ︙ | ︙ |
Changes to generic/tclProc.c.
| ︙ | ︙ | |||
144 145 146 147 148 149 150 151 152 153 154 |
*
* Side effects:
* A new procedure gets created.
*
*----------------------------------------------------------------------
*/
int
Tcl_ProcObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| > | | 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 |
*
* Side effects:
* A new procedure gets created.
*
*----------------------------------------------------------------------
*/
#undef TclObjInterpProc
int
Tcl_ProcObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
size_t objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr;
const char *procName;
const char *simpleName, *procArgs, *procBody;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
|
| ︙ | ︙ | |||
400 401 402 403 404 405 406 |
Tcl_Obj *argsPtr, /* Description of arguments. */
Tcl_Obj *bodyPtr, /* Command body. */
Proc **procPtrPtr) /* Returns: pointer to proc data. */
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr = NULL;
| | | | 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 |
Tcl_Obj *argsPtr, /* Description of arguments. */
Tcl_Obj *bodyPtr, /* Command body. */
Proc **procPtrPtr) /* Returns: pointer to proc data. */
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr = NULL;
size_t i, numArgs;
CompiledLocal *localPtr = NULL;
Tcl_Obj **argArray;
int precompiled = 0, result;
ProcGetIntRep(bodyPtr, procPtr);
if (procPtr != NULL) {
/*
* Because the body is a TclProProcBody, the actual body is already
* compiled, and it is not shared with anyone else, so it's OK not to
* unshare it (as a matter of fact, it is bad to unshare it, because
|
| ︙ | ︙ | |||
480 481 482 483 484 485 486 |
/*
* Break up the argument list into argument specifiers, then process each
* argument specifier. If the body is precompiled, processing is limited
* to checking that the parsed argument is consistent with the one stored
* in the Proc.
*/
| | | | | < | | 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 |
/*
* Break up the argument list into argument specifiers, then process each
* argument specifier. If the body is precompiled, processing is limited
* to checking that the parsed argument is consistent with the one stored
* in the Proc.
*/
result = TclListObjGetElementsM(interp , argsPtr ,&numArgs ,&argArray);
if (result != TCL_OK) {
goto procError;
}
if (precompiled) {
if (numArgs > procPtr->numArgs) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"procedure \"%s\": arg list contains %" TCL_Z_MODIFIER "u entries, "
"precompiled header expects %" TCL_Z_MODIFIER "u", procName, numArgs,
procPtr->numArgs));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"BYTECODELIES", NULL);
goto procError;
}
localPtr = procPtr->firstLocalPtr;
} else {
procPtr->numArgs = numArgs;
procPtr->numCompiledLocals = numArgs;
}
for (i = 0; i < numArgs; i++) {
const char *argname, *argnamei, *argnamelast;
size_t fieldCount, nameLength;
Tcl_Obj **fieldValues;
/*
* Now divide the specifier up into name and default.
*/
result = TclListObjGetElementsM(interp, argArray[i], &fieldCount,
&fieldValues);
if (result != TCL_OK) {
goto procError;
}
if (fieldCount > 2) {
Tcl_Obj *errorObj = Tcl_NewStringObj(
"too many fields in argument specifier \"", -1);
|
| ︙ | ︙ | |||
584 585 586 587 588 589 590 |
if ((localPtr->nameLength != nameLength)
|| (memcmp(localPtr->name, argname, nameLength) != 0)
|| (localPtr->frameIndex != i)
|| !(localPtr->flags & VAR_ARGUMENT)
|| (localPtr->defValuePtr == NULL && fieldCount == 2)
|| (localPtr->defValuePtr != NULL && fieldCount != 2)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 |
if ((localPtr->nameLength != nameLength)
|| (memcmp(localPtr->name, argname, nameLength) != 0)
|| (localPtr->frameIndex != i)
|| !(localPtr->flags & VAR_ARGUMENT)
|| (localPtr->defValuePtr == NULL && fieldCount == 2)
|| (localPtr->defValuePtr != NULL && fieldCount != 2)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"procedure \"%s\": formal parameter %" TCL_Z_MODIFIER "u is "
"inconsistent with precompiled body", procName, i));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"BYTECODELIES", NULL);
goto procError;
}
/*
|
| ︙ | ︙ | |||
826 827 828 829 830 831 832 |
}
level = curLevel - 1;
}
if (level >= 0) {
CallFrame *framePtr;
for (framePtr = iPtr->varFramePtr; framePtr != NULL;
framePtr = framePtr->callerVarPtr) {
| | | 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 |
}
level = curLevel - 1;
}
if (level >= 0) {
CallFrame *framePtr;
for (framePtr = iPtr->varFramePtr; framePtr != NULL;
framePtr = framePtr->callerVarPtr) {
if ((int)framePtr->level == level) {
*framePtrPtr = framePtr;
return result;
}
}
}
}
badLevel:
|
| ︙ | ︙ | |||
915 916 917 918 919 920 921 |
* is only one argument. This requires a TIP since currently a single
* argument is interpreted as a level indicator if possible.
*/
uplevelSyntax:
Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
return TCL_ERROR;
} else if (!TclHasStringRep(objv[1]) && objc == 2) {
| | > | | 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 |
* is only one argument. This requires a TIP since currently a single
* argument is interpreted as a level indicator if possible.
*/
uplevelSyntax:
Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
return TCL_ERROR;
} else if (!TclHasStringRep(objv[1]) && objc == 2) {
int status;
size_t llength;
status = TclListObjLengthM(interp, objv[1], &llength);
if (status == TCL_OK && llength > 1) {
/* the first argument can't interpreted as a level. Avoid
* generating a string representation of the script. */
result = TclGetFrame(interp, "1", &framePtr);
if (result == -1) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1242 1243 1244 1245 1246 1247 1248 |
}
void
TclFreeLocalCache(
Tcl_Interp *interp,
LocalCache *localCachePtr)
{
| | | | | 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 |
}
void
TclFreeLocalCache(
Tcl_Interp *interp,
LocalCache *localCachePtr)
{
size_t i;
Tcl_Obj **namePtrPtr = &localCachePtr->varName0;
for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) {
Tcl_Obj *objPtr = *namePtrPtr;
if (objPtr) {
/* TclReleaseLiteral calls Tcl_DecrRefCount for us */
TclReleaseLiteral(interp, objPtr);
}
}
Tcl_Free(localCachePtr);
}
static void
InitLocalCache(
Proc *procPtr)
{
Interp *iPtr = procPtr->iPtr;
ByteCode *codePtr;
size_t localCt = procPtr->numCompiledLocals;
size_t numArgs = procPtr->numArgs, i = 0;
Tcl_Obj **namePtr;
Var *varPtr;
LocalCache *localCachePtr;
CompiledLocal *localPtr;
int isNew;
|
| ︙ | ︙ | |||
1426 1427 1428 1429 1430 1431 1432 |
/*
* When we get here, the last formal argument remains to be defined:
* defPtr and varPtr point to the last argument to be initialized.
*/
varPtr->flags = 0;
if (defPtr && defPtr->flags & VAR_IS_ARGS) {
| | | 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 |
/*
* When we get here, the last formal argument remains to be defined:
* defPtr and varPtr point to the last argument to be initialized.
*/
varPtr->flags = 0;
if (defPtr && defPtr->flags & VAR_IS_ARGS) {
Tcl_Obj *listPtr = Tcl_NewListObj((argCt>i)? argCt-i : 0, argObjs+i);
varPtr->value.objPtr = listPtr;
Tcl_IncrRefCount(listPtr); /* Local var is a reference. */
} else if (argCt == numArgs) {
Tcl_Obj *objPtr = argObjs[i];
varPtr->value.objPtr = objPtr;
|
| ︙ | ︙ | |||
1500 1501 1502 1503 1504 1505 1506 |
int
TclPushProcCallFrame(
ClientData clientData, /* Record describing procedure to be
* interpreted. */
Tcl_Interp *interp,/* Interpreter in which procedure was
* invoked. */
| | > > | > > | 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 |
int
TclPushProcCallFrame(
ClientData clientData, /* Record describing procedure to be
* interpreted. */
Tcl_Interp *interp,/* Interpreter in which procedure was
* invoked. */
size_t objc1, /* Count of number of arguments to this
* procedure. */
Tcl_Obj *const objv[], /* Argument value objects. */
int isLambda) /* 1 if this is a call by ApplyObjCmd: it
* needs special rules for error msg */
{
Proc *procPtr = (Proc *)clientData;
Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
CallFrame *framePtr, **framePtrPtr;
int result;
ByteCode *codePtr;
int objc = objc1;
/*
* If necessary (i.e. if we haven't got a suitable compilation already
* cached) compile the procedure's body. The compiler will allocate frame
* slots for the procedure's non-argument local variables. Note that
* compiling the body might increase procPtr->numCompiledLocals if new
* local variables are found while compiling.
*/
ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
if (codePtr != NULL) {
Interp *iPtr = (Interp *) interp;
/*
* When we've got bytecode, this is the check for validity. That is,
* the bytecode must be for the right interpreter (no cross-leaks!),
* the code must be from the current epoch (so subcommand compilation
* is up-to-date), the namespace must match (so variable handling
* is right) and the resolverEpoch must match (so that new shadowed
* commands and/or resolver changes are considered).
* Ensure the ByteCode's procPtr is the same (or it's precompiled).
*/
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != nsPtr)
|| (codePtr->nsEpoch != nsPtr->resolverEpoch)
|| ((codePtr->procPtr != procPtr) && procPtr->bodyPtr->bytes)
) {
goto doCompilation;
}
} else {
doCompilation:
result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
(isLambda ? "body of lambda term" : "body of proc"),
TclGetString(objv[isLambda]));
|
| ︙ | ︙ | |||
1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 |
*
* Side effects:
* Depends on the commands in the procedure.
*
*----------------------------------------------------------------------
*/
int
TclObjInterpProc(
ClientData clientData, /* Record describing procedure to be
* interpreted. */
Tcl_Interp *interp,/* Interpreter in which procedure was
* invoked. */
int objc, /* Count of number of arguments to this
| > | 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 |
*
* Side effects:
* Depends on the commands in the procedure.
*
*----------------------------------------------------------------------
*/
#undef TclObjInterpProc
int
TclObjInterpProc(
ClientData clientData, /* Record describing procedure to be
* interpreted. */
Tcl_Interp *interp,/* Interpreter in which procedure was
* invoked. */
int objc, /* Count of number of arguments to this
|
| ︙ | ︙ | |||
1670 1671 1672 1673 1674 1675 1676 |
TclStackFree(interp, freePtr); /* Free CallFrame. */
return TCL_ERROR;
}
#if defined(TCL_COMPILE_DEBUG)
if (tclTraceExec >= 1) {
CallFrame *framePtr = iPtr->varFramePtr;
| | | | | | | 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 |
TclStackFree(interp, freePtr); /* Free CallFrame. */
return TCL_ERROR;
}
#if defined(TCL_COMPILE_DEBUG)
if (tclTraceExec >= 1) {
CallFrame *framePtr = iPtr->varFramePtr;
size_t i;
if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
fprintf(stdout, "Calling lambda ");
} else {
fprintf(stdout, "Calling proc ");
}
for (i = 0; i < framePtr->objc; i++) {
TclPrintObject(stdout, framePtr->objv[i], 15);
fprintf(stdout, " ");
}
fprintf(stdout, "\n");
fflush(stdout);
}
#endif /*TCL_COMPILE_DEBUG*/
#ifdef USE_DTRACE
if (TCL_DTRACE_PROC_ARGS_ENABLED()) {
size_t l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
const char *a[10];
size_t i;
for (i = 0 ; i < 10 ; i++) {
a[i] = (l < iPtr->varFramePtr->objc ?
TclGetString(iPtr->varFramePtr->objv[l]) : NULL);
l++;
}
TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
a[8], a[9]);
}
if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) {
Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr);
const char *a[6]; int i[2];
TclDTraceInfo(info, a, i);
TCL_DTRACE_PROC_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]);
TclDecrRefCount(info);
}
if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
size_t l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ?
TclGetString(iPtr->varFramePtr->objv[l]) : NULL,
iPtr->varFramePtr->objc - l - 1,
(Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1));
}
if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
size_t l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ?
TclGetString(iPtr->varFramePtr->objv[l]) : NULL,
iPtr->varFramePtr->objc - l - 1,
(Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1));
}
#endif /* USE_DTRACE */
|
| ︙ | ︙ | |||
1751 1752 1753 1754 1755 1756 1757 |
Interp *iPtr = (Interp *) interp;
Proc *procPtr = iPtr->varFramePtr->procPtr;
CallFrame *freePtr;
Tcl_Obj *procNameObj = (Tcl_Obj *)data[0];
ProcErrorProc *errorProc = (ProcErrorProc *)data[1];
if (TCL_DTRACE_PROC_RETURN_ENABLED()) {
| | | 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 |
Interp *iPtr = (Interp *) interp;
Proc *procPtr = iPtr->varFramePtr->procPtr;
CallFrame *freePtr;
Tcl_Obj *procNameObj = (Tcl_Obj *)data[0];
ProcErrorProc *errorProc = (ProcErrorProc *)data[1];
if (TCL_DTRACE_PROC_RETURN_ENABLED()) {
size_t l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
TCL_DTRACE_PROC_RETURN(l < iPtr->varFramePtr->objc ?
TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result);
}
if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
}
|
| ︙ | ︙ | |||
1774 1775 1776 1777 1778 1779 1780 |
if (result != TCL_OK) {
goto process;
}
done:
if (TCL_DTRACE_PROC_RESULT_ENABLED()) {
| | | 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 |
if (result != TCL_OK) {
goto process;
}
done:
if (TCL_DTRACE_PROC_RESULT_ENABLED()) {
size_t l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
Tcl_Obj *r = Tcl_GetObjResult(interp);
TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ?
TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result,
TclGetString(r), r);
}
|
| ︙ | ︙ | |||
1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 |
* ByteCode already exists, make sure it hasn't been invalidated by
* someone redefining a core command (this might make the compiled code
* wrong). Also, if the code was compiled in/for a different interpreter,
* we recompile it. Note that compiling the body might increase
* procPtr->numCompiledLocals if new local variables are found while
* compiling.
*
* Precompiled procedure bodies, however, are immutable and therefore they
* are not recompiled, even if things have changed.
*/
if (codePtr != NULL) {
if (((Interp *) *codePtr->interpHandle == iPtr)
&& (codePtr->compileEpoch == iPtr->compileEpoch)
&& (codePtr->nsPtr == nsPtr)
| > | > > | 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 |
* ByteCode already exists, make sure it hasn't been invalidated by
* someone redefining a core command (this might make the compiled code
* wrong). Also, if the code was compiled in/for a different interpreter,
* we recompile it. Note that compiling the body might increase
* procPtr->numCompiledLocals if new local variables are found while
* compiling.
*
* Ensure the ByteCode's procPtr is the same (or it is pure precompiled).
* Precompiled procedure bodies, however, are immutable and therefore they
* are not recompiled, even if things have changed.
*/
if (codePtr != NULL) {
if (((Interp *) *codePtr->interpHandle == iPtr)
&& (codePtr->compileEpoch == iPtr->compileEpoch)
&& (codePtr->nsPtr == nsPtr)
&& (codePtr->nsEpoch == nsPtr->resolverEpoch)
&& ((codePtr->procPtr == procPtr) || !bodyPtr->bytes)
) {
return TCL_OK;
}
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
if ((Interp *) *codePtr->interpHandle != iPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"a precompiled script jumped interps", -1));
|
| ︙ | ︙ | |||
2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 |
Tcl_Obj *defPtr;
Tcl_ResolvedVarInfo *resVarInfo;
Tcl_HashEntry *hePtr = NULL;
CmdFrame *cfPtr = NULL;
Interp *iPtr = procPtr->iPtr;
if (bodyPtr != NULL) {
Tcl_DecrRefCount(bodyPtr);
}
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) {
CompiledLocal *nextPtr = localPtr->nextPtr;
resVarInfo = localPtr->resolveInfo;
if (resVarInfo) {
| > > > > > > > | 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 |
Tcl_Obj *defPtr;
Tcl_ResolvedVarInfo *resVarInfo;
Tcl_HashEntry *hePtr = NULL;
CmdFrame *cfPtr = NULL;
Interp *iPtr = procPtr->iPtr;
if (bodyPtr != NULL) {
/* procPtr is stored in body's ByteCode, so ensure to reset it. */
ByteCode *codePtr;
ByteCodeGetInternalRep(bodyPtr, &tclByteCodeType, codePtr);
if (codePtr != NULL && codePtr->procPtr == procPtr) {
codePtr->procPtr = NULL;
}
Tcl_DecrRefCount(bodyPtr);
}
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) {
CompiledLocal *nextPtr = localPtr->nextPtr;
resVarInfo = localPtr->resolveInfo;
if (resVarInfo) {
|
| ︙ | ︙ | |||
2220 2221 2222 2223 2224 2225 2226 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_ObjCmdProc *
TclGetObjInterpProc(void)
{
return TclObjInterpProc;
}
/*
*----------------------------------------------------------------------
*
* TclNewProcBodyObj --
*
|
| ︙ | ︙ | |||
2379 2380 2381 2382 2383 2384 2385 |
SetLambdaFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
Interp *iPtr = (Interp *) interp;
const char *name;
Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv;
| | > | | 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 |
SetLambdaFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
Interp *iPtr = (Interp *) interp;
const char *name;
Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv;
int isNew, result;
size_t objc;
CmdFrame *cfPtr = NULL;
Proc *procPtr;
if (interp == NULL) {
return TCL_ERROR;
}
/*
* Convert objPtr to list type first; if it cannot be converted, or if its
* length is not 2, then it cannot be converted to lambdaType.
*/
result = TclListObjGetElementsM(NULL, objPtr, &objc, &objv);
if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't interpret \"%s\" as a lambda expression",
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ |
Changes to generic/tclProcess.c.
| ︙ | ︙ | |||
398 399 400 401 402 403 404 | * Access to the internal structures is protected by infoTablesMutex. * *---------------------------------------------------------------------- */ static int ProcessListObjCmd( | | | 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 |
* Access to the internal structures is protected by infoTablesMutex.
*
*----------------------------------------------------------------------
*/
static int
ProcessListObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *list;
Tcl_HashEntry *entry;
Tcl_HashSearch search;
|
| ︙ | ︙ | |||
449 450 451 452 453 454 455 | * Calls RefreshProcessInfo, which can block if -wait switch is given. * *---------------------------------------------------------------------- */ static int ProcessStatusObjCmd( | | | < | 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 |
* Calls RefreshProcessInfo, which can block if -wait switch is given.
*
*----------------------------------------------------------------------
*/
static int
ProcessStatusObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *dict;
int options = WNOHANG;
Tcl_HashEntry *entry;
Tcl_HashSearch search;
ProcessInfo *info;
size_t i, numPids;
Tcl_Obj **pidObjs;
int result;
int pid;
Tcl_Obj *const *savedobjv = objv;
static const char *const switches[] = {
"-wait", "--", NULL
};
enum switchesEnum {
STATUS_WAIT, STATUS_LAST
|
| ︙ | ︙ | |||
529 530 531 532 533 534 535 |
}
Tcl_MutexUnlock(&infoTablesMutex);
} else {
/*
* Only return statuses of provided processes.
*/
| | | 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 |
}
Tcl_MutexUnlock(&infoTablesMutex);
} else {
/*
* Only return statuses of provided processes.
*/
result = TclListObjGetElementsM(interp, objv[1], &numPids, &pidObjs);
if (result != TCL_OK) {
return result;
}
dict = Tcl_NewDictObj();
Tcl_MutexLock(&infoTablesMutex);
for (i = 0; i < numPids; i++) {
result = Tcl_GetIntFromObj(interp, pidObjs[i], &pid);
|
| ︙ | ︙ | |||
597 598 599 600 601 602 603 | * Frees all ProcessInfo structures with their purge flag set. * *---------------------------------------------------------------------- */ static int ProcessPurgeObjCmd( | | | | < < | 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 |
* Frees all ProcessInfo structures with their purge flag set.
*
*----------------------------------------------------------------------
*/
static int
ProcessPurgeObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_HashEntry *entry;
Tcl_HashSearch search;
ProcessInfo *info;
size_t i, numPids;
Tcl_Obj **pidObjs;
int result, pid;
if (objc != 1 && objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?pids?");
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
644 645 646 647 648 649 650 |
}
Tcl_MutexUnlock(&infoTablesMutex);
} else {
/*
* Purge only provided processes.
*/
| | | 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 |
}
Tcl_MutexUnlock(&infoTablesMutex);
} else {
/*
* Purge only provided processes.
*/
result = TclListObjGetElementsM(interp, objv[1], &numPids, &pidObjs);
if (result != TCL_OK) {
return result;
}
Tcl_MutexLock(&infoTablesMutex);
for (i = 0; i < numPids; i++) {
result = Tcl_GetIntFromObj(interp, pidObjs[i], &pid);
if (result != TCL_OK) {
|
| ︙ | ︙ | |||
697 698 699 700 701 702 703 | * Alters detached process handling by Tcl_ReapDetachedProcs(). * *---------------------------------------------------------------------- */ static int ProcessAutopurgeObjCmd( | | | 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 |
* Alters detached process handling by Tcl_ReapDetachedProcs().
*
*----------------------------------------------------------------------
*/
static int
ProcessAutopurgeObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 1 && objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?flag?");
|
| ︙ | ︙ |
Changes to generic/tclRegexp.c.
| ︙ | ︙ | |||
84 85 86 87 88 89 90 | * Declarations for functions used only in this file. */ static TclRegexp * CompileRegexp(Tcl_Interp *interp, const char *pattern, size_t length, int flags); static void DupRegexpInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); | | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 | * Declarations for functions used only in this file. */ static TclRegexp * CompileRegexp(Tcl_Interp *interp, const char *pattern, size_t length, int flags); static void DupRegexpInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FinalizeRegexp(void *clientData); static void FreeRegexp(TclRegexp *regexpPtr); static void FreeRegexpInternalRep(Tcl_Obj *objPtr); static int RegExpExecUniChar(Tcl_Interp *interp, Tcl_RegExp re, const Tcl_UniChar *uniString, size_t numChars, size_t nmatches, int flags); static int SetRegexpFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); |
| ︙ | ︙ | |||
151 152 153 154 155 156 157 |
Tcl_RegExp
Tcl_RegExpCompile(
Tcl_Interp *interp, /* For use in error reporting and to access
* the interp regexp cache. */
const char *pattern) /* String for which to produce compiled
* regular expression. */
{
| | | 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 |
Tcl_RegExp
Tcl_RegExpCompile(
Tcl_Interp *interp, /* For use in error reporting and to access
* the interp regexp cache. */
const char *pattern) /* String for which to produce compiled
* regular expression. */
{
return (Tcl_RegExp) CompileRegexp(interp, pattern, strlen(pattern),
REG_ADVANCED);
}
/*
*----------------------------------------------------------------------
*
* Tcl_RegExpExec --
|
| ︙ | ︙ | |||
914 915 916 917 918 919 920 |
/*
* This is a new expression, so compile it and add it to the cache.
*/
regexpPtr = (TclRegexp*)Tcl_Alloc(sizeof(TclRegexp));
regexpPtr->objPtr = NULL;
regexpPtr->string = NULL;
| | | | 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 |
/*
* This is a new expression, so compile it and add it to the cache.
*/
regexpPtr = (TclRegexp*)Tcl_Alloc(sizeof(TclRegexp));
regexpPtr->objPtr = NULL;
regexpPtr->string = NULL;
regexpPtr->details.rm_extend.rm_so = TCL_INDEX_NONE;
regexpPtr->details.rm_extend.rm_eo = TCL_INDEX_NONE;
/*
* Get the up-to-date string representation and map to unicode.
*/
Tcl_DStringInit(&stringBuf);
uniString = Tcl_UtfToUniCharDString(string, length, &stringBuf);
|
| ︙ | ︙ |
Changes to generic/tclResult.c.
| ︙ | ︙ | |||
21 22 23 24 25 26 27 | }; /* * Function prototypes for local functions in this file: */ static Tcl_Obj ** GetKeys(void); | | | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | }; /* * Function prototypes for local functions in this file: */ static Tcl_Obj ** GetKeys(void); static void ReleaseKeys(void *clientData); static void ResetObjResult(Interp *iPtr); /* * This structure is used to take a snapshot of the interpreter state in * Tcl_SaveInterpState. You can snapshot the state, execute a command, and * then back up to the result or the error that was previously in progress. */ |
| ︙ | ︙ | |||
655 656 657 658 659 660 661 | * Frees memory. * *---------------------------------------------------------------------- */ static void ReleaseKeys( | | | 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 |
* Frees memory.
*
*----------------------------------------------------------------------
*/
static void
ReleaseKeys(
void *clientData)
{
Tcl_Obj **keys = (Tcl_Obj **)clientData;
int i;
for (i = KEY_CODE; i < KEY_LAST; i++) {
Tcl_DecrRefCount(keys[i]);
keys[i] = NULL;
|
| ︙ | ︙ | |||
729 730 731 732 733 734 735 |
Tcl_IncrRefCount(iPtr->errorInfo);
iPtr->flags |= ERR_ALREADY_LOGGED;
}
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK],
&valuePtr);
if (valuePtr != NULL) {
| | | | | 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 |
Tcl_IncrRefCount(iPtr->errorInfo);
iPtr->flags |= ERR_ALREADY_LOGGED;
}
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK],
&valuePtr);
if (valuePtr != NULL) {
size_t len, valueObjc;
Tcl_Obj **valueObjv;
if (Tcl_IsShared(iPtr->errorStack)) {
Tcl_Obj *newObj;
newObj = Tcl_DuplicateObj(iPtr->errorStack);
Tcl_DecrRefCount(iPtr->errorStack);
Tcl_IncrRefCount(newObj);
iPtr->errorStack = newObj;
}
/*
* List extraction done after duplication to avoid moving the rug
* if someone does [return -errorstack [info errorstack]]
*/
if (TclListObjGetElementsM(interp, valuePtr, &valueObjc,
&valueObjv) == TCL_ERROR) {
return TCL_ERROR;
}
iPtr->resetErrorStack = 0;
TclListObjLengthM(interp, iPtr->errorStack, &len);
/*
* Reset while keeping the list internalrep as much as possible.
*/
Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc,
valueObjv);
|
| ︙ | ︙ | |||
906 907 908 909 910 911 912 |
/*
* Check for bogus -errorcode value.
*/
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORCODE], &valuePtr);
if (valuePtr != NULL) {
| | | | | | 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 |
/*
* Check for bogus -errorcode value.
*/
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORCODE], &valuePtr);
if (valuePtr != NULL) {
size_t length;
if (TCL_ERROR == TclListObjLengthM(NULL, valuePtr, &length )) {
/*
* Value is not a list, which is illegal for -errorcode.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad -errorcode value: expected a list but got \"%s\"",
TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_ERRORCODE",
NULL);
goto error;
}
}
/*
* Check for bogus -errorstack value.
*/
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORSTACK], &valuePtr);
if (valuePtr != NULL) {
size_t length;
if (TCL_ERROR == TclListObjLengthM(NULL, valuePtr, &length)) {
/*
* Value is not a list, which is illegal for -errorstack.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad -errorstack value: expected a list but got \"%s\"",
TclGetString(valuePtr)));
|
| ︙ | ︙ | |||
1096 1097 1098 1099 1100 1101 1102 |
*/
int
Tcl_SetReturnOptions(
Tcl_Interp *interp,
Tcl_Obj *options)
{
| > | | | 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 |
*/
int
Tcl_SetReturnOptions(
Tcl_Interp *interp,
Tcl_Obj *options)
{
size_t objc;
int level, code;
Tcl_Obj **objv, *mergedOpts;
Tcl_IncrRefCount(options);
if (TCL_ERROR == TclListObjGetElementsM(interp, options, &objc, &objv)
|| (objc % 2)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected dict but got \"%s\"", TclGetString(options)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", NULL);
code = TCL_ERROR;
} else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv,
&mergedOpts, &code, &level)) {
|
| ︙ | ︙ |
Changes to generic/tclStrToD.c.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 | /* * gcc on x86 needs access to rounding controls, because of a questionable * feature where it retains intermediate results as IEEE 'long double' values * somewhat unpredictably. It is tempting to include fpu_control.h, but that * file exists only on Linux; it is missing on Cygwin and MinGW. Most gcc-isms * and ix86-isms are factored out here. */ | < | | | | | | | > | | | > | | > > | < | < < < | | | 45 46 47 48 49 50 51 52 53 54 55 56 57 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 91 92 93 94 95 |
/*
* gcc on x86 needs access to rounding controls, because of a questionable
* feature where it retains intermediate results as IEEE 'long double' values
* somewhat unpredictably. It is tempting to include fpu_control.h, but that
* file exists only on Linux; it is missing on Cygwin and MinGW. Most gcc-isms
* and ix86-isms are factored out here.
*/
# if defined(__GNUC__)
typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__)));
# define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw))
# define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw))
# define FPU_IEEE_ROUNDING 0x027F
# define ADJUST_FPU_CONTROL_WORD
# define TCL_IEEE_DOUBLE_ROUNDING_DECL \
fpu_control_t roundTo53Bits = FPU_IEEE_ROUNDING; \
fpu_control_t oldRoundingMode;
# define TCL_IEEE_DOUBLE_ROUNDING \
_FPU_GETCW(oldRoundingMode); \
_FPU_SETCW(roundTo53Bits)
# define TCL_DEFAULT_DOUBLE_ROUNDING \
_FPU_SETCW(oldRoundingMode)
/*
* Sun ProC needs sunmath for rounding control on x86 like gcc above.
*/
# elif defined(__sun)
# include <sunmath.h>
# define TCL_IEEE_DOUBLE_ROUNDING_DECL
# define TCL_IEEE_DOUBLE_ROUNDING \
ieee_flags("set","precision","double",NULL)
# define TCL_DEFAULT_DOUBLE_ROUNDING \
ieee_flags("clear","precision",NULL,NULL)
# endif
#endif
/*
* Other platforms are assumed to always operate in full IEEE mode, so we make
* the macros to go in and out of that mode do nothing.
*/
#ifndef TCL_IEEE_DOUBLE_ROUNDING /* !__i386 || (!__GNUC__ && !__sun) */
# define TCL_IEEE_DOUBLE_ROUNDING_DECL
# define TCL_IEEE_DOUBLE_ROUNDING ((void) 0)
# define TCL_DEFAULT_DOUBLE_ROUNDING ((void) 0)
#endif
/*
* MIPS floating-point units need special settings in control registers to use
* gradual underflow as we expect. This fix is for the MIPSpro compiler.
*/
|
| ︙ | ︙ | |||
382 383 384 385 386 387 388 | * number in a format recognized by Tcl. * * The arguments bytes, numBytes, and objPtr are the inputs which * determine the string to be parsed. If bytes is non-NULL, it points to * the first byte to be scanned. If bytes is NULL, then objPtr must be * non-NULL, and the string representation of objPtr will be scanned * (generated first, if necessary). The numBytes argument determines the | | | | | 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 | * number in a format recognized by Tcl. * * The arguments bytes, numBytes, and objPtr are the inputs which * determine the string to be parsed. If bytes is non-NULL, it points to * the first byte to be scanned. If bytes is NULL, then objPtr must be * non-NULL, and the string representation of objPtr will be scanned * (generated first, if necessary). The numBytes argument determines the * number of bytes to be scanned. If numBytes is TCL_INDEX_NONE, the first NUL * byte encountered will terminate the scan. Otherwise, * no more than numBytes bytes will be scanned. * * The argument flags is an input that controls the numeric formats * recognized by the parser. The flag bits are: * * - TCL_PARSE_INTEGER_ONLY: accept only integer values; reject * strings that denote floating point values (or accept only the * leading portion of them that are integer values). |
| ︙ | ︙ | |||
552 553 554 555 556 557 558 |
if (bytes == NULL) {
if (interp == NULL && endPtrPtr == NULL) {
if (TclHasInternalRep(objPtr, &tclDictType)) {
/* A dict can never be a (single) number */
return TCL_ERROR;
}
if (TclHasInternalRep(objPtr, &tclListType)) {
| | | | 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 |
if (bytes == NULL) {
if (interp == NULL && endPtrPtr == NULL) {
if (TclHasInternalRep(objPtr, &tclDictType)) {
/* A dict can never be a (single) number */
return TCL_ERROR;
}
if (TclHasInternalRep(objPtr, &tclListType)) {
size_t length;
/* A list can only be a (single) number if its length == 1 */
TclListObjLengthM(NULL, objPtr, &length);
if (length != 1) {
return TCL_ERROR;
}
}
}
bytes = TclGetString(objPtr);
}
|
| ︙ | ︙ | |||
1206 1207 1208 1209 1210 1211 1212 | #endif case sINFINITY: acceptState = state; acceptPoint = p; acceptLen = len; goto endgame; | < | 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 |
#endif
case sINFINITY:
acceptState = state;
acceptPoint = p;
acceptLen = len;
goto endgame;
}
p++;
len--;
}
endgame:
if (acceptState == INITIAL) {
|
| ︙ | ︙ | |||
1675 1676 1677 1678 1679 1680 1681 |
static double
MakeLowPrecisionDouble(
int signum, /* 1 if the number is negative, 0 otherwise */
Tcl_WideUInt significand, /* Significand of the number */
int numSigDigs, /* Number of digits in the significand */
long exponent) /* Power of ten */
{
| > | | > | < | > < > > > > > > > | 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 |
static double
MakeLowPrecisionDouble(
int signum, /* 1 if the number is negative, 0 otherwise */
Tcl_WideUInt significand, /* Significand of the number */
int numSigDigs, /* Number of digits in the significand */
long exponent) /* Power of ten */
{
TCL_IEEE_DOUBLE_ROUNDING_DECL
mp_int significandBig; /* Significand expressed as a bignum. */
/*
* With gcc on x86, the floating point rounding mode is double-extended.
* This causes the result of double-precision calculations to be rounded
* twice: once to the precision of double-extended and then again to the
* precision of double. Double-rounding introduces gratuitous errors of 1
* ulp, so we need to change rounding mode to 53-bits. We also make
* 'retval' volatile, so that it doesn't get promoted to a register.
*/
volatile double retval; /* Value of the number. */
/*
* Test for zero significand, which requires explicit construction
* of -0.0. (Unary minus returns a positive zero.)
*/
if (significand == 0) {
return copysign(0.0, -signum);
}
/*
* Set the FP control word for 53 bits, WARNING: It must be reset
* before returning.
*/
TCL_IEEE_DOUBLE_ROUNDING;
if (numSigDigs <= QUICK_MAX) {
if (exponent >= 0) {
if (exponent <= mmaxpow) {
/*
* The significand is an exact integer, and so is
* 10**exponent. The product will be correct to within 1/2 ulp
* without special handling.
|
| ︙ | ︙ | |||
1794 1795 1796 1797 1798 1799 1800 |
static double
MakeHighPrecisionDouble(
int signum, /* 1=negative, 0=nonnegative */
mp_int *significand, /* Exact significand of the number */
int numSigDigs, /* Number of significant digits */
long exponent) /* Power of 10 by which to multiply */
{
| > | | > > | < < | > < > > > > > > > > > > > | 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 |
static double
MakeHighPrecisionDouble(
int signum, /* 1=negative, 0=nonnegative */
mp_int *significand, /* Exact significand of the number */
int numSigDigs, /* Number of significant digits */
long exponent) /* Power of 10 by which to multiply */
{
TCL_IEEE_DOUBLE_ROUNDING_DECL
int machexp = 0; /* Machine exponent of a power of 10. */
/*
* With gcc on x86, the floating point rounding mode is double-extended.
* This causes the result of double-precision calculations to be rounded
* twice: once to the precision of double-extended and then again to the
* precision of double. Double-rounding introduces gratuitous errors of 1
* ulp, so we need to change rounding mode to 53-bits. We also make
* 'retval' volatile to make sure that it doesn't get promoted to a
* register.
*/
volatile double retval;
/*
* A zero significand requires explicit construction of -0.0.
* (Unary minus returns positive zero.)
*/
if (mp_iszero(significand)) {
return copysign(0.0, -signum);
}
/*
* Set the 53-bit rounding mode. WARNING: It must be reset before
* returning.
*/
TCL_IEEE_DOUBLE_ROUNDING;
/*
* Make quick checks for over/underflow. Be careful to avoid
* integer overflow when calculating with 'exponent'.
*/
if (exponent >= 0 && exponent-1 > maxDigits-numSigDigs) {
retval = HUGE_VAL;
goto returnValue;
} else if (exponent < 0 && numSigDigs+exponent < minDigits+1) {
retval = 0.0;
goto returnValue;
}
|
| ︙ | ︙ |
Changes to generic/tclStringObj.c.
| ︙ | ︙ | |||
66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 | static void GrowUnicodeBuffer(Tcl_Obj *objPtr, size_t needed); static int SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t numChars); static size_t UnicodeLength(const Tcl_UniChar *unicode); static void UpdateStringOfString(Tcl_Obj *objPtr); #define ISCONTINUATION(bytes) (\ ((((bytes)[0] & 0xC0) == 0x80) || (((bytes)[0] == '\xED') \ && (((bytes)[1] & 0xF0) == 0xB0) && (((bytes)[2] & 0xC0) == 0x80)))) /* * The structure below defines the string Tcl object type by means of * functions that can be invoked by generic object code. */ | > > > > > | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 | static void GrowUnicodeBuffer(Tcl_Obj *objPtr, size_t needed); static int SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t numChars); static size_t UnicodeLength(const Tcl_UniChar *unicode); static void UpdateStringOfString(Tcl_Obj *objPtr); #if TCL_UTF_MAX > 3 #define ISCONTINUATION(bytes) (\ ((bytes)[0] & 0xC0) == 0x80) #else #define ISCONTINUATION(bytes) (\ ((((bytes)[0] & 0xC0) == 0x80) || (((bytes)[0] == '\xED') \ && (((bytes)[1] & 0xF0) == 0xB0) && (((bytes)[2] & 0xC0) == 0x80)))) #endif /* * The structure below defines the string Tcl object type by means of * functions that can be invoked by generic object code. */ |
| ︙ | ︙ | |||
234 235 236 237 238 239 240 | * of calling the debugging version Tcl_DbNewStringObj. * * Results: * A newly created string object is returned that has ref count zero. * * Side effects: * The new object's internal string representation will be set to a copy | | | | 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 |
* of calling the debugging version Tcl_DbNewStringObj.
*
* Results:
* A newly created string object is returned that has ref count zero.
*
* Side effects:
* The new object's internal string representation will be set to a copy
* of the length bytes starting at "bytes". If "length" is TCL_INDEX_NONE, use
* bytes up to the first NUL byte; i.e., assume "bytes" points to a
* C-style NUL-terminated string. The object's type is set to NULL. An
* extra NUL is added to the end of the new object's byte array.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewStringObj
Tcl_Obj *
Tcl_NewStringObj(
const char *bytes, /* Points to the first of the length bytes
* used to initialize the new object. */
ssize_t length) /* The number of bytes to copy from "bytes"
* when initializing the new object. If
* TCL_INDEX_NONE, use bytes up to the first NUL
* byte. */
{
return Tcl_DbNewStringObj(bytes, length, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewStringObj(
|
| ︙ | ︙ | |||
295 296 297 298 299 300 301 | * result of calling Tcl_NewStringObj. * * Results: * A newly created string object is returned that has ref count zero. * * Side effects: * The new object's internal string representation will be set to a copy | | | 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 | * result of calling Tcl_NewStringObj. * * Results: * A newly created string object is returned that has ref count zero. * * Side effects: * The new object's internal string representation will be set to a copy * of the length bytes starting at "bytes". If "length" is TCL_INDEX_NONE, use * bytes up to the first NUL byte; i.e., assume "bytes" points to a * C-style NUL-terminated string. The object's type is set to NULL. An * extra NUL is added to the end of the new object's byte array. * *---------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
500 501 502 503 504 505 506 |
*
*----------------------------------------------------------------------
*/
int
TclCheckEmptyString(
Tcl_Obj *objPtr)
{
| | | | 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 |
*
*----------------------------------------------------------------------
*/
int
TclCheckEmptyString(
Tcl_Obj *objPtr)
{
size_t length = TCL_INDEX_NONE;
if (objPtr->bytes == &tclEmptyString) {
return TCL_EMPTYSTRING_YES;
}
if (TclListObjIsCanonical(objPtr)) {
TclListObjLengthM(NULL, objPtr, &length);
return length == 0;
}
if (TclIsPureDict(objPtr)) {
Tcl_DictObjSize(NULL, objPtr, &length);
return length == 0;
}
|
| ︙ | ︙ | |||
682 683 684 685 686 687 688 689 690 691 692 693 694 695 |
if (stringPtr->hasUnicode == 0) {
FillUnicodeRep(objPtr);
stringPtr = GET_STRING(objPtr);
}
if (lengthPtr != NULL) {
*lengthPtr = (int)stringPtr->numChars;
}
return stringPtr->unicode;
}
Tcl_UniChar *
Tcl_GetUnicodeFromObj(
| > > > > | 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 |
if (stringPtr->hasUnicode == 0) {
FillUnicodeRep(objPtr);
stringPtr = GET_STRING(objPtr);
}
if (lengthPtr != NULL) {
if (stringPtr->numChars > INT_MAX) {
Tcl_Panic("Tcl_GetUnicodeFromObj with 'int' lengthPtr"
"cannot handle such long strings. Please use 'size_t'");
}
*lengthPtr = (int)stringPtr->numChars;
}
return stringPtr->unicode;
}
Tcl_UniChar *
Tcl_GetUnicodeFromObj(
|
| ︙ | ︙ | |||
878 879 880 881 882 883 884 | * indicated by the byte pointer and length arguments. * * Results: * None. * * Side effects: * The object's string representation will be set to a copy of the | | | 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 | * indicated by the byte pointer and length arguments. * * Results: * None. * * Side effects: * The object's string representation will be set to a copy of the * "length" bytes starting at "bytes". If "length" is TCL_INDEX_NONE, use bytes * up to the first NUL byte; i.e., assume "bytes" points to a C-style * NUL-terminated string. The object's old string and internal * representations are freed and the object's type is set NULL. * *---------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
1827 1828 1829 1830 1831 1832 1833 |
*/
int
Tcl_AppendFormatToObj(
Tcl_Interp *interp,
Tcl_Obj *appendObj,
const char *format,
| | | | | 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 |
*/
int
Tcl_AppendFormatToObj(
Tcl_Interp *interp,
Tcl_Obj *appendObj,
const char *format,
size_t objc,
Tcl_Obj *const objv[])
{
const char *span = format, *msg, *errCode;
int gotXpg = 0, gotSequential = 0;
size_t objIndex = 0, originalLength, limit, numBytes = 0;
Tcl_UniChar ch = 0;
static const char *mixedXPG =
"cannot mix \"%\" and \"%n$\" conversion specifiers";
static const char *const badIndex[2] = {
"not enough arguments for all format specifiers",
"\"%n$\" argument index out of range"
};
|
| ︙ | ︙ | |||
1924 1925 1926 1927 1928 1929 1930 |
if (gotXpg) {
msg = mixedXPG;
errCode = "MIXEDSPECTYPES";
goto errorMsg;
}
gotSequential = 1;
}
| | | 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 |
if (gotXpg) {
msg = mixedXPG;
errCode = "MIXEDSPECTYPES";
goto errorMsg;
}
gotSequential = 1;
}
if (objIndex >= objc) {
msg = badIndex[gotXpg];
errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
goto errorMsg;
}
/*
* Step 2. Set of flags.
|
| ︙ | ︙ | |||
2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 |
char buf[4] = "";
int code, length;
if (TclGetIntFromObj(interp, segment, &code) != TCL_OK) {
goto error;
}
length = Tcl_UniCharToUtf(code, buf);
if ((code >= 0xD800) && (length < 3)) {
/* Special case for handling high surrogates. */
length += Tcl_UniCharToUtf(-1, buf + length);
}
segment = Tcl_NewStringObj(buf, length);
Tcl_IncrRefCount(segment);
allocSegment = 1;
break;
}
case 'u':
| > > | 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 |
char buf[4] = "";
int code, length;
if (TclGetIntFromObj(interp, segment, &code) != TCL_OK) {
goto error;
}
length = Tcl_UniCharToUtf(code, buf);
#if TCL_UTF_MAX < 4
if ((code >= 0xD800) && (length < 3)) {
/* Special case for handling high surrogates. */
length += Tcl_UniCharToUtf(-1, buf + length);
}
#endif
segment = Tcl_NewStringObj(buf, length);
Tcl_IncrRefCount(segment);
allocSegment = 1;
break;
}
case 'u':
|
| ︙ | ︙ | |||
2594 2595 2596 2597 2598 2599 2600 |
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_Format(
Tcl_Interp *interp,
const char *format,
| | | 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 |
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_Format(
Tcl_Interp *interp,
const char *format,
size_t objc,
Tcl_Obj *const objv[])
{
int result;
Tcl_Obj *objPtr;
TclNewObj(objPtr);
result = Tcl_AppendFormatToObj(interp, objPtr, format, objc, objv);
|
| ︙ | ︙ | |||
2627 2628 2629 2630 2631 2632 2633 |
static void
AppendPrintfToObjVA(
Tcl_Obj *objPtr,
const char *format,
va_list argList)
{
| | > | 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 |
static void
AppendPrintfToObjVA(
Tcl_Obj *objPtr,
const char *format,
va_list argList)
{
int code;
size_t objc;
Tcl_Obj **objv, *list;
const char *p;
TclNewObj(list);
p = format;
Tcl_IncrRefCount(list);
while (*p != '\0') {
|
| ︙ | ︙ | |||
2788 2789 2790 2791 2792 2793 2794 |
size = -1;
/* FALLTHRU */
default:
p++;
}
} while (seekingConversion);
}
| | | 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 |
size = -1;
/* FALLTHRU */
default:
p++;
}
} while (seekingConversion);
}
TclListObjGetElementsM(NULL, list, &objc, &objv);
code = Tcl_AppendFormatToObj(NULL, objPtr, format, objc, objv);
if (code != TCL_OK) {
Tcl_AppendPrintfToObj(objPtr,
"Unable to format \"%s\" with supplied arguments: %s",
format, TclGetString(list));
}
Tcl_DecrRefCount(list);
|
| ︙ | ︙ | |||
4173 4174 4175 4176 4177 4178 4179 |
stringPtr->numChars = needed;
} else {
numAppendChars = 0;
}
dst = stringPtr->unicode + numOrigChars;
if (numAppendChars-- > 0) {
bytes += TclUtfToUniChar(bytes, &unichar);
| < < < < < < < < | 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 |
stringPtr->numChars = needed;
} else {
numAppendChars = 0;
}
dst = stringPtr->unicode + numOrigChars;
if (numAppendChars-- > 0) {
bytes += TclUtfToUniChar(bytes, &unichar);
*dst++ = unichar;
while (numAppendChars-- > 0) {
bytes += TclUtfToUniChar(bytes, &unichar);
*dst++ = unichar;
}
}
*dst = 0;
|
| ︙ | ︙ |
Changes to generic/tclStubInit.c.
| ︙ | ︙ | |||
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 91 92 93 94 95 96 97 |
#undef TclStaticLibrary
#undef Tcl_BackgroundError
#define TclStaticLibrary Tcl_StaticLibrary
#undef Tcl_UniCharToUtfDString
#undef Tcl_UtfToUniCharDString
#undef Tcl_UtfToUniChar
#undef Tcl_UniCharLen
#if !defined(_WIN32) && !defined(__CYGWIN__)
#undef Tcl_WinConvertError
#define Tcl_WinConvertError 0
#endif
#if TCL_UTF_MAX < 4
static void uniCodePanic() {
Tcl_Panic("This extension uses a deprecated function, not available now: Tcl is compiled with -DTCL_UTF_MAX==%d", TCL_UTF_MAX);
}
# define Tcl_GetUnicodeFromObj (Tcl_UniChar *(*)(Tcl_Obj *, size_t *))(void *)uniCodePanic
# define TclGetUnicodeFromObj (Tcl_UniChar *(*)(Tcl_Obj *, int *))(void *)uniCodePanic
# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const Tcl_UniChar *, size_t))(void *)uniCodePanic
# define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, size_t))(void *)uniCodePanic
# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, size_t))(void *)uniCodePanic
#endif
#define TclUtfCharComplete Tcl_UtfCharComplete
#define TclUtfNext Tcl_UtfNext
#define TclUtfPrev Tcl_UtfPrev
#define TclBN_mp_add mp_add
#define TclBN_mp_add_d mp_add_d
#define TclBN_mp_and mp_and
#define TclBN_mp_clamp mp_clamp
#define TclBN_mp_clear mp_clear
#define TclBN_mp_clear_multi mp_clear_multi
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 |
#undef TclStaticLibrary
#undef Tcl_BackgroundError
#define TclStaticLibrary Tcl_StaticLibrary
#undef Tcl_UniCharToUtfDString
#undef Tcl_UtfToUniCharDString
#undef Tcl_UtfToUniChar
#undef Tcl_UniCharLen
#undef TclObjInterpProc
#if !defined(_WIN32) && !defined(__CYGWIN__)
#undef Tcl_WinConvertError
#define Tcl_WinConvertError 0
#endif
#undef Tcl_Close
#define Tcl_Close 0
#undef TclGetByteArrayFromObj
#define TclGetByteArrayFromObj 0
#undef Tcl_GetByteArrayFromObj
#define Tcl_GetByteArrayFromObj 0
#if TCL_UTF_MAX < 4
static void uniCodePanic() {
Tcl_Panic("This extension uses a deprecated function, not available now: Tcl is compiled with -DTCL_UTF_MAX==%d", TCL_UTF_MAX);
}
# define Tcl_GetUnicodeFromObj (Tcl_UniChar *(*)(Tcl_Obj *, size_t *))(void *)uniCodePanic
# define TclGetUnicodeFromObj (Tcl_UniChar *(*)(Tcl_Obj *, int *))(void *)uniCodePanic
# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const Tcl_UniChar *, size_t))(void *)uniCodePanic
# define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, size_t))(void *)uniCodePanic
# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, size_t))(void *)uniCodePanic
#endif
#define TclUtfCharComplete Tcl_UtfCharComplete
#define TclUtfNext Tcl_UtfNext
#define TclUtfPrev Tcl_UtfPrev
int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr,
int *objcPtr, Tcl_Obj ***objvPtr) {
size_t n = TCL_INDEX_NONE;
int result = Tcl_ListObjGetElements(interp, listPtr, &n, objvPtr);
if (objcPtr) {
if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) {
if (interp) {
Tcl_AppendResult(interp, "List too large to be processed", NULL);
}
return TCL_ERROR;
}
*objcPtr = n;
}
return result;
}
int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
int *lengthPtr) {
size_t n = TCL_INDEX_NONE;
int result = Tcl_ListObjLength(interp, listPtr, &n);
if (lengthPtr) {
if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) {
if (interp) {
Tcl_AppendResult(interp, "List too large to be processed", NULL);
}
return TCL_ERROR;
}
*lengthPtr = n;
}
return result;
}
int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr,
int *sizePtr) {
size_t n = TCL_INDEX_NONE;
int result = Tcl_DictObjSize(interp, dictPtr, &n);
if (sizePtr) {
if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) {
if (interp) {
Tcl_AppendResult(interp, "Dict too large to be processed", NULL);
}
return TCL_ERROR;
}
*sizePtr = n;
}
return result;
}
int TclSplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr,
const char ***argvPtr) {
size_t n = TCL_INDEX_NONE;
int result = Tcl_SplitList(interp, listStr, &n, argvPtr);
if (argcPtr) {
if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) {
if (interp) {
Tcl_AppendResult(interp, "List too large to be processed", NULL);
}
Tcl_Free((void *)*argvPtr);
return TCL_ERROR;
}
*argcPtr = n;
}
return result;
}
void TclSplitPath(const char *path, int *argcPtr, const char ***argvPtr) {
size_t n = TCL_INDEX_NONE;
Tcl_SplitPath(path, &n, argvPtr);
if (argcPtr) {
if ((sizeof(int) != sizeof(size_t)) && (n > INT_MAX)) {
n = TCL_INDEX_NONE; /* No other way to return an error-situation */
Tcl_Free((void *)*argvPtr);
*argvPtr = NULL;
}
*argcPtr = n;
}
}
Tcl_Obj *TclFSSplitPath(Tcl_Obj *pathPtr, int *lenPtr) {
size_t n = TCL_INDEX_NONE;
Tcl_Obj *result = Tcl_FSSplitPath(pathPtr, &n);
if (lenPtr) {
if ((sizeof(int) != sizeof(size_t)) && result && (n > INT_MAX)) {
Tcl_DecrRefCount(result);
return NULL;
}
*lenPtr = n;
}
return result;
}
int TclParseArgsObjv(Tcl_Interp *interp,
const Tcl_ArgvInfo *argTable, int *objcPtr, Tcl_Obj *const *objv,
Tcl_Obj ***remObjv) {
size_t n = (*objcPtr < 0) ? TCL_INDEX_NONE: (size_t)*objcPtr ;
int result = Tcl_ParseArgsObjv(interp, argTable, &n, objv, remObjv);
*objcPtr = (int)n;
return result;
}
#define TclBN_mp_add mp_add
#define TclBN_mp_add_d mp_add_d
#define TclBN_mp_and mp_and
#define TclBN_mp_clamp mp_clamp
#define TclBN_mp_clear mp_clear
#define TclBN_mp_clear_multi mp_clear_multi
|
| ︙ | ︙ | |||
223 224 225 226 227 228 229 |
int result = Tcl_ExprLong(interp, expr, &longValue);
if (result == TCL_OK) {
if ((longValue >= (long)(INT_MIN))
&& (longValue <= (long)(UINT_MAX))) {
*ptr = (int)longValue;
} else {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | | 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 |
int result = Tcl_ExprLong(interp, expr, &longValue);
if (result == TCL_OK) {
if ((longValue >= (long)(INT_MIN))
&& (longValue <= (long)(UINT_MAX))) {
*ptr = (int)longValue;
} else {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"integer value too large to represent", -1));
result = TCL_ERROR;
}
}
return result;
}
#define Tcl_ExprLong (int(*)(Tcl_Interp*,const char*,long*))exprInt
static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){
long longValue;
int result = Tcl_ExprLongObj(interp, expr, &longValue);
if (result == TCL_OK) {
if ((longValue >= (long)(INT_MIN))
&& (longValue <= (long)(UINT_MAX))) {
*ptr = (int)longValue;
} else {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"integer value too large to represent", -1));
result = TCL_ERROR;
}
}
return result;
}
#define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))exprIntObj
static int utfNcmp(const char *s1, const char *s2, unsigned int n){
|
| ︙ | ︙ | |||
547 548 549 550 551 552 553 554 555 556 557 558 559 560 |
TclPtrGetVar, /* 252 */
TclPtrSetVar, /* 253 */
TclPtrIncrObjVar, /* 254 */
TclPtrObjMakeUpvar, /* 255 */
TclPtrUnsetVar, /* 256 */
TclStaticLibrary, /* 257 */
TclpCreateTemporaryDirectory, /* 258 */
};
static const TclIntPlatStubs tclIntPlatStubs = {
TCL_STUB_MAGIC,
0,
0, /* 0 */
TclpCloseFile, /* 1 */
| > > > | 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 |
TclPtrGetVar, /* 252 */
TclPtrSetVar, /* 253 */
TclPtrIncrObjVar, /* 254 */
TclPtrObjMakeUpvar, /* 255 */
TclPtrUnsetVar, /* 256 */
TclStaticLibrary, /* 257 */
TclpCreateTemporaryDirectory, /* 258 */
0, /* 259 */
TclListTestObj, /* 260 */
TclListObjValidate, /* 261 */
};
static const TclIntPlatStubs tclIntPlatStubs = {
TCL_STUB_MAGIC,
0,
0, /* 0 */
TclpCloseFile, /* 1 */
|
| ︙ | ︙ | |||
734 735 736 737 738 739 740 |
Tcl_GetIntFromObj, /* 38 */
Tcl_GetLongFromObj, /* 39 */
Tcl_GetObjType, /* 40 */
TclGetStringFromObj, /* 41 */
Tcl_InvalidateStringRep, /* 42 */
Tcl_ListObjAppendList, /* 43 */
Tcl_ListObjAppendElement, /* 44 */
| | | | 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 |
Tcl_GetIntFromObj, /* 38 */
Tcl_GetLongFromObj, /* 39 */
Tcl_GetObjType, /* 40 */
TclGetStringFromObj, /* 41 */
Tcl_InvalidateStringRep, /* 42 */
Tcl_ListObjAppendList, /* 43 */
Tcl_ListObjAppendElement, /* 44 */
TclListObjGetElements, /* 45 */
Tcl_ListObjIndex, /* 46 */
TclListObjLength, /* 47 */
Tcl_ListObjReplace, /* 48 */
0, /* 49 */
Tcl_NewByteArrayObj, /* 50 */
Tcl_NewDoubleObj, /* 51 */
0, /* 52 */
Tcl_NewListObj, /* 53 */
0, /* 54 */
|
| ︙ | ︙ | |||
770 771 772 773 774 775 776 |
Tcl_AsyncMark, /* 74 */
Tcl_AsyncReady, /* 75 */
0, /* 76 */
0, /* 77 */
Tcl_BadChannelOption, /* 78 */
Tcl_CallWhenDeleted, /* 79 */
Tcl_CancelIdleCall, /* 80 */
| | | 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 |
Tcl_AsyncMark, /* 74 */
Tcl_AsyncReady, /* 75 */
0, /* 76 */
0, /* 77 */
Tcl_BadChannelOption, /* 78 */
Tcl_CallWhenDeleted, /* 79 */
Tcl_CancelIdleCall, /* 80 */
Tcl_Close, /* 81 */
Tcl_CommandComplete, /* 82 */
Tcl_Concat, /* 83 */
Tcl_ConvertElement, /* 84 */
Tcl_ConvertCountedElement, /* 85 */
Tcl_CreateAlias, /* 86 */
Tcl_CreateAliasObj, /* 87 */
Tcl_CreateChannel, /* 88 */
|
| ︙ | ︙ | |||
931 932 933 934 935 936 937 |
Tcl_SetObjResult, /* 235 */
Tcl_SetStdChannel, /* 236 */
0, /* 237 */
Tcl_SetVar2, /* 238 */
Tcl_SignalId, /* 239 */
Tcl_SignalMsg, /* 240 */
Tcl_SourceRCFile, /* 241 */
| | | | 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 |
Tcl_SetObjResult, /* 235 */
Tcl_SetStdChannel, /* 236 */
0, /* 237 */
Tcl_SetVar2, /* 238 */
Tcl_SignalId, /* 239 */
Tcl_SignalMsg, /* 240 */
Tcl_SourceRCFile, /* 241 */
TclSplitList, /* 242 */
TclSplitPath, /* 243 */
0, /* 244 */
0, /* 245 */
0, /* 246 */
0, /* 247 */
Tcl_TraceVar2, /* 248 */
Tcl_TranslateFileName, /* 249 */
Tcl_Ungets, /* 250 */
|
| ︙ | ︙ | |||
1150 1151 1152 1153 1154 1155 1156 |
Tcl_FSStat, /* 454 */
Tcl_FSAccess, /* 455 */
Tcl_FSOpenFileChannel, /* 456 */
Tcl_FSGetCwd, /* 457 */
Tcl_FSChdir, /* 458 */
Tcl_FSConvertToPathType, /* 459 */
Tcl_FSJoinPath, /* 460 */
| | | 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 |
Tcl_FSStat, /* 454 */
Tcl_FSAccess, /* 455 */
Tcl_FSOpenFileChannel, /* 456 */
Tcl_FSGetCwd, /* 457 */
Tcl_FSChdir, /* 458 */
Tcl_FSConvertToPathType, /* 459 */
Tcl_FSJoinPath, /* 460 */
TclFSSplitPath, /* 461 */
Tcl_FSEqualPaths, /* 462 */
Tcl_FSGetNormalizedPath, /* 463 */
Tcl_FSJoinToPath, /* 464 */
Tcl_FSGetInternalRep, /* 465 */
Tcl_FSGetTranslatedPath, /* 466 */
Tcl_FSEvalFile, /* 467 */
Tcl_FSNewNativePath, /* 468 */
|
| ︙ | ︙ | |||
1186 1187 1188 1189 1190 1191 1192 |
Tcl_AllocStatBuf, /* 490 */
Tcl_Seek, /* 491 */
Tcl_Tell, /* 492 */
Tcl_ChannelWideSeekProc, /* 493 */
Tcl_DictObjPut, /* 494 */
Tcl_DictObjGet, /* 495 */
Tcl_DictObjRemove, /* 496 */
| | | 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 |
Tcl_AllocStatBuf, /* 490 */
Tcl_Seek, /* 491 */
Tcl_Tell, /* 492 */
Tcl_ChannelWideSeekProc, /* 493 */
Tcl_DictObjPut, /* 494 */
Tcl_DictObjGet, /* 495 */
Tcl_DictObjRemove, /* 496 */
TclDictObjSize, /* 497 */
Tcl_DictObjFirst, /* 498 */
Tcl_DictObjNext, /* 499 */
Tcl_DictObjDone, /* 500 */
Tcl_DictObjPutKeyList, /* 501 */
Tcl_DictObjRemoveKeyList, /* 502 */
Tcl_NewDictObj, /* 503 */
Tcl_DbNewDictObj, /* 504 */
|
| ︙ | ︙ | |||
1293 1294 1295 1296 1297 1298 1299 |
Tcl_GetModificationTimeFromStat, /* 597 */
Tcl_GetChangeTimeFromStat, /* 598 */
Tcl_GetSizeFromStat, /* 599 */
Tcl_GetBlocksFromStat, /* 600 */
Tcl_GetBlockSizeFromStat, /* 601 */
Tcl_SetEnsembleParameterList, /* 602 */
Tcl_GetEnsembleParameterList, /* 603 */
| | | 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 |
Tcl_GetModificationTimeFromStat, /* 597 */
Tcl_GetChangeTimeFromStat, /* 598 */
Tcl_GetSizeFromStat, /* 599 */
Tcl_GetBlocksFromStat, /* 600 */
Tcl_GetBlockSizeFromStat, /* 601 */
Tcl_SetEnsembleParameterList, /* 602 */
Tcl_GetEnsembleParameterList, /* 603 */
TclParseArgsObjv, /* 604 */
Tcl_GetErrorLine, /* 605 */
Tcl_SetErrorLine, /* 606 */
Tcl_TransferResult, /* 607 */
Tcl_InterpActive, /* 608 */
Tcl_BackgroundException, /* 609 */
Tcl_ZlibDeflate, /* 610 */
Tcl_ZlibInflate, /* 611 */
|
| ︙ | ︙ | |||
1350 1351 1352 1353 1354 1355 1356 |
Tcl_UtfCharComplete, /* 654 */
Tcl_UtfNext, /* 655 */
Tcl_UtfPrev, /* 656 */
Tcl_UniCharIsUnicode, /* 657 */
Tcl_ExternalToUtfDStringEx, /* 658 */
Tcl_UtfToExternalDStringEx, /* 659 */
Tcl_AsyncMarkFromSignal, /* 660 */
| | | | | | | | > > > > > > | 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 1478 1479 1480 1481 |
Tcl_UtfCharComplete, /* 654 */
Tcl_UtfNext, /* 655 */
Tcl_UtfPrev, /* 656 */
Tcl_UniCharIsUnicode, /* 657 */
Tcl_ExternalToUtfDStringEx, /* 658 */
Tcl_UtfToExternalDStringEx, /* 659 */
Tcl_AsyncMarkFromSignal, /* 660 */
Tcl_ListObjGetElements, /* 661 */
Tcl_ListObjLength, /* 662 */
Tcl_DictObjSize, /* 663 */
Tcl_SplitList, /* 664 */
Tcl_SplitPath, /* 665 */
Tcl_FSSplitPath, /* 666 */
Tcl_ParseArgsObjv, /* 667 */
Tcl_UniCharLen, /* 668 */
Tcl_NumUtfChars, /* 669 */
Tcl_GetCharLength, /* 670 */
Tcl_UtfAtIndex, /* 671 */
Tcl_GetRange, /* 672 */
Tcl_GetUniChar, /* 673 */
0, /* 674 */
0, /* 675 */
Tcl_CreateObjCommand2, /* 676 */
Tcl_CreateObjTrace2, /* 677 */
Tcl_NRCreateCommand2, /* 678 */
Tcl_NRCallObjProc2, /* 679 */
};
/* !END!: Do not edit above this line. */
|
Changes to generic/tclStubLib.c.
| ︙ | ︙ | |||
54 55 56 57 58 59 60 |
Tcl_Interp *interp,
const char *version,
int exact,
int magic)
{
Interp *iPtr = (Interp *)interp;
const char *actualVersion = NULL;
| | > > | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 |
Tcl_Interp *interp,
const char *version,
int exact,
int magic)
{
Interp *iPtr = (Interp *)interp;
const char *actualVersion = NULL;
void *pkgData = NULL;
const TclStubs *stubsPtr = iPtr->stubTable;
const char *tclName = (((exact&0xFF00) >= 0x900) ? "tcl" : "Tcl");
#undef TCL_STUB_MAGIC /* We need the TCL_STUB_MAGIC from Tcl 8.x here */
#define TCL_STUB_MAGIC ((int) 0xFCA3BACF)
/*
* We can't optimize this check by caching tclStubsPtr because that
* prevents apps from being able to load/unload Tcl dynamically multiple
* times. [Bug 615304]
*/
if (!stubsPtr || (stubsPtr->magic != (((exact&0xFF00) >= 0x900) ? magic : TCL_STUB_MAGIC))) {
|
| ︙ | ︙ |
Changes to generic/tclTest.c.
| ︙ | ︙ | |||
50 51 52 53 54 55 56 57 58 59 60 61 62 63 |
* Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect
* the results of the various deletion callbacks.
*/
static Tcl_DString delString;
static Tcl_Interp *delInterp;
/*
* One of the following structures exists for each asynchronous handler
* created by the "testasync" command".
*/
typedef struct TestAsyncHandler {
int id; /* Identifier for this handler. */
| > > > > > > > > > > > > > > > | 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 |
* Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect
* the results of the various deletion callbacks.
*/
static Tcl_DString delString;
static Tcl_Interp *delInterp;
/*
* One of the following structures exists for each command created by the
* "testcmdtoken" command.
*/
typedef struct TestCommandTokenRef {
int id; /* Identifier for this reference. */
Tcl_Command token; /* Tcl's token for the command. */
struct TestCommandTokenRef *nextPtr;
/* Next in list of references. */
} TestCommandTokenRef;
static TestCommandTokenRef *firstCommandTokenRef = NULL;
static int nextCommandTokenRefId = 1;
/*
* One of the following structures exists for each asynchronous handler
* created by the "testasync" command".
*/
typedef struct TestAsyncHandler {
int id; /* Identifier for this handler. */
|
| ︙ | ︙ | |||
72 73 74 75 76 77 78 |
* Start of the socket driver state structure to acces field testFlags
*/
typedef struct TcpState TcpState;
struct TcpState {
Tcl_Channel channel; /* Channel associated with this socket. */
| | < | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 |
* Start of the socket driver state structure to acces field testFlags
*/
typedef struct TcpState TcpState;
struct TcpState {
Tcl_Channel channel; /* Channel associated with this socket. */
int flags; /* ORed combination of various bitfields. */
};
TCL_DECLARE_MUTEX(asyncTestMutex)
static TestAsyncHandler *firstHandler = NULL;
/*
|
| ︙ | ︙ | |||
247 248 249 250 251 252 253 254 255 256 257 258 259 260 | static Tcl_CmdProc TestgetintCmd; static Tcl_CmdProc TestlongsizeCmd; static Tcl_CmdProc TestgetplatformCmd; static Tcl_ObjCmdProc TestgetvarfullnameCmd; static Tcl_CmdProc TestinterpdeleteCmd; static Tcl_CmdProc TestlinkCmd; static Tcl_ObjCmdProc TestlinkarrayCmd; static Tcl_ObjCmdProc TestlocaleCmd; static Tcl_CmdProc TestmainthreadCmd; static Tcl_CmdProc TestsetmainloopCmd; static Tcl_CmdProc TestexitmainloopCmd; static Tcl_CmdProc TestpanicCmd; static Tcl_ObjCmdProc TestparseargsCmd; static Tcl_ObjCmdProc TestparserObjCmd; | > | 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 | static Tcl_CmdProc TestgetintCmd; static Tcl_CmdProc TestlongsizeCmd; static Tcl_CmdProc TestgetplatformCmd; static Tcl_ObjCmdProc TestgetvarfullnameCmd; static Tcl_CmdProc TestinterpdeleteCmd; static Tcl_CmdProc TestlinkCmd; static Tcl_ObjCmdProc TestlinkarrayCmd; static Tcl_ObjCmdProc TestlistrepCmd; static Tcl_ObjCmdProc TestlocaleCmd; static Tcl_CmdProc TestmainthreadCmd; static Tcl_CmdProc TestsetmainloopCmd; static Tcl_CmdProc TestexitmainloopCmd; static Tcl_CmdProc TestpanicCmd; static Tcl_ObjCmdProc TestparseargsCmd; static Tcl_ObjCmdProc TestparserObjCmd; |
| ︙ | ︙ | |||
273 274 275 276 277 278 279 | static Tcl_CmdProc Testset2Cmd; static Tcl_CmdProc TestseterrorcodeCmd; static Tcl_ObjCmdProc TestsetobjerrorcodeCmd; static Tcl_CmdProc TestsetplatformCmd; static Tcl_CmdProc TeststaticlibraryCmd; static Tcl_CmdProc TesttranslatefilenameCmd; static Tcl_CmdProc TestupvarCmd; | | | 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 | static Tcl_CmdProc Testset2Cmd; static Tcl_CmdProc TestseterrorcodeCmd; static Tcl_ObjCmdProc TestsetobjerrorcodeCmd; static Tcl_CmdProc TestsetplatformCmd; static Tcl_CmdProc TeststaticlibraryCmd; static Tcl_CmdProc TesttranslatefilenameCmd; static Tcl_CmdProc TestupvarCmd; static Tcl_ObjCmdProc2 TestWrongNumArgsObjCmd; static Tcl_ObjCmdProc TestGetIndexFromObjStructObjCmd; static Tcl_CmdProc TestChannelCmd; static Tcl_CmdProc TestChannelEventCmd; static Tcl_CmdProc TestSocketCmd; static Tcl_ObjCmdProc TestFilesystemObjCmd; static Tcl_ObjCmdProc TestSimpleFilesystemObjCmd; static void TestReport(const char *cmd, Tcl_Obj *arg1, |
| ︙ | ︙ | |||
331 332 333 334 335 336 337 338 339 340 341 342 343 344 |
static Tcl_NRPostProc NREUnwind_callback;
static Tcl_ObjCmdProc TestNREUnwind;
static Tcl_ObjCmdProc TestNRELevels;
static Tcl_ObjCmdProc TestInterpResolverCmd;
#if defined(HAVE_CPUID) && !defined(MAC_OSX_TCL)
static Tcl_ObjCmdProc TestcpuidCmd;
#endif
static const Tcl_Filesystem testReportingFilesystem = {
"reporting",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_1,
TestReportInFilesystem, /* path in */
TestReportDupInternalRep,
| > | 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 |
static Tcl_NRPostProc NREUnwind_callback;
static Tcl_ObjCmdProc TestNREUnwind;
static Tcl_ObjCmdProc TestNRELevels;
static Tcl_ObjCmdProc TestInterpResolverCmd;
#if defined(HAVE_CPUID) && !defined(MAC_OSX_TCL)
static Tcl_ObjCmdProc TestcpuidCmd;
#endif
static Tcl_ObjCmdProc TestApplyLambdaObjCmd;
static const Tcl_Filesystem testReportingFilesystem = {
"reporting",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_1,
TestReportInFilesystem, /* path in */
TestReportDupInternalRep,
|
| ︙ | ︙ | |||
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 |
}
#endif
if (Tcl_OOInitStubs(interp) == NULL) {
return TCL_ERROR;
}
if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) {
Tcl_CreateObjCommand(interp, "::tcl::test::build-info",
info.objProc, (void *)version, NULL);
}
if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) {
return TCL_ERROR;
}
/*
* Create additional commands and math functions for testing Tcl.
*/
Tcl_CreateObjCommand(interp, "gettimes", GetTimesObjCmd, NULL, NULL);
Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testpurebytesobj", TestpurebytesobjObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL);
| > > > > > > | | 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 |
}
#endif
if (Tcl_OOInitStubs(interp) == NULL) {
return TCL_ERROR;
}
if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) {
#if TCL_MAJOR_VERSION > 8
if (info.isNativeObjectProc == 2) {
Tcl_CreateObjCommand2(interp, "::tcl::test::build-info",
info.objProc2, (void *)version, NULL);
} else
#endif
Tcl_CreateObjCommand(interp, "::tcl::test::build-info",
info.objProc, (void *)version, NULL);
}
if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) {
return TCL_ERROR;
}
/*
* Create additional commands and math functions for testing Tcl.
*/
Tcl_CreateObjCommand(interp, "gettimes", GetTimesObjCmd, NULL, NULL);
Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testpurebytesobj", TestpurebytesobjObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL);
Tcl_CreateObjCommand2(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct",
TestGetIndexFromObjStructObjCmd, NULL, NULL);
|
| ︙ | ︙ | |||
630 631 632 633 634 635 636 637 638 639 640 641 642 643 |
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetvarfullname",
TestgetvarfullnameCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testlinkarray", TestlinkarrayCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL);
Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd,
| > | 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 |
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetvarfullname",
TestgetvarfullnameCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testlinkarray", TestlinkarrayCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testlistrep", TestlistrepCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL);
Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd,
|
| ︙ | ︙ | |||
705 706 707 708 709 710 711 712 713 714 715 716 717 718 |
NULL, NULL);
Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetencpath", TestgetencpathObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetencpath", TestsetencpathObjCmd,
NULL, NULL);
if (TclObjTest_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
if (Procbodytest_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
| > > | 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 |
NULL, NULL);
Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetencpath", TestgetencpathObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetencpath", TestsetencpathObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testapplylambda", TestApplyLambdaObjCmd,
NULL, NULL);
if (TclObjTest_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
if (Procbodytest_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
742 743 744 745 746 747 748 |
case 2: {
int mode;
Tcl_UnregisterChannel(interp,
Tcl_GetChannel(interp, "stderr", &mode));
return TCL_ERROR;
}
case 3:
| | | 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 |
case 2: {
int mode;
Tcl_UnregisterChannel(interp,
Tcl_GetChannel(interp, "stderr", &mode));
return TCL_ERROR;
}
case 3:
if (objc > 1) {
Tcl_SetVar2Ex(interp, "tcl_rcFileName", NULL, objv[1],
TCL_GLOBAL_ONLY);
}
return TCL_ERROR;
}
}
}
|
| ︙ | ︙ | |||
787 788 789 790 791 792 793 794 795 796 797 798 799 800 |
{
Tcl_CmdInfo info;
if (Tcl_InitStubs(interp, "8.7-", 0) == NULL) {
return TCL_ERROR;
}
if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) {
Tcl_CreateObjCommand(interp, "::tcl::test::build-info",
info.objProc, (void *)version, NULL);
}
if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) {
return TCL_ERROR;
}
return Procbodytest_SafeInit(interp);
| > > > > > > | 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 |
{
Tcl_CmdInfo info;
if (Tcl_InitStubs(interp, "8.7-", 0) == NULL) {
return TCL_ERROR;
}
if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) {
#if TCL_MAJOR_VERSION > 8
if (info.isNativeObjectProc == 2) {
Tcl_CreateObjCommand2(interp, "::tcl::test::build-info",
info.objProc2, (void *)version, NULL);
} else
#endif
Tcl_CreateObjCommand(interp, "::tcl::test::build-info",
info.objProc, (void *)version, NULL);
}
if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) {
return TCL_ERROR;
}
return Procbodytest_SafeInit(interp);
|
| ︙ | ︙ | |||
897 898 899 900 901 902 903 |
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) {
Tcl_AsyncMark(asyncPtr->handler);
break;
}
}
| | | 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 |
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) {
Tcl_AsyncMark(asyncPtr->handler);
break;
}
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], TCL_INDEX_NONE));
Tcl_MutexUnlock(&asyncTestMutex);
return code;
} else if (strcmp(argv[1], "marklater") == 0) {
if (argc != 3) {
goto wrongNumArgs;
}
if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) {
|
| ︙ | ︙ | |||
966 967 968 969 970 971 972 |
TclFormatInt(string, code);
listArgv[0] = asyncPtr->command;
listArgv[1] = Tcl_GetStringResult(interp);
listArgv[2] = string;
listArgv[3] = NULL;
cmd = Tcl_Merge(3, listArgv);
if (interp != NULL) {
| | | 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 |
TclFormatInt(string, code);
listArgv[0] = asyncPtr->command;
listArgv[1] = Tcl_GetStringResult(interp);
listArgv[2] = string;
listArgv[3] = NULL;
cmd = Tcl_Merge(3, listArgv);
if (interp != NULL) {
code = Tcl_EvalEx(interp, cmd, TCL_INDEX_NONE, 0);
} else {
/*
* this should not happen, but by definition of how async handlers are
* invoked, it's possible. Better error checking is needed here.
*/
}
Tcl_Free(cmd);
|
| ︙ | ︙ | |||
1147 1148 1149 1150 1151 1152 1153 |
}
static void
CmdDelProc1(
void *clientData) /* String to save. */
{
Tcl_DStringInit(&delString);
| | | | | | 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 |
}
static void
CmdDelProc1(
void *clientData) /* String to save. */
{
Tcl_DStringInit(&delString);
Tcl_DStringAppend(&delString, "CmdDelProc1 ", TCL_INDEX_NONE);
Tcl_DStringAppend(&delString, (char *) clientData, TCL_INDEX_NONE);
}
static void
CmdDelProc2(
void *clientData) /* String to save. */
{
Tcl_DStringInit(&delString);
Tcl_DStringAppend(&delString, "CmdDelProc2 ", TCL_INDEX_NONE);
Tcl_DStringAppend(&delString, (char *) clientData, TCL_INDEX_NONE);
}
/*
*----------------------------------------------------------------------
*
* TestcmdtokenCmd --
*
|
| ︙ | ︙ | |||
1184 1185 1186 1187 1188 1189 1190 |
static int
TestcmdtokenCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
| | < > > | > > > > | | > > > > > > > > > > > > > | | | 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 |
static int
TestcmdtokenCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
TestCommandTokenRef *refPtr;
char buf[30];
int id;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" option arg\"", NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
refPtr = (TestCommandTokenRef *)Tcl_Alloc(sizeof(TestCommandTokenRef));
refPtr->token = Tcl_CreateCommand(interp, argv[2], CmdProc1,
(void *) "original", NULL);
refPtr->id = nextCommandTokenRefId;
nextCommandTokenRefId++;
refPtr->nextPtr = firstCommandTokenRef;
firstCommandTokenRef = refPtr;
sprintf(buf, "%d", refPtr->id);
Tcl_AppendResult(interp, buf, NULL);
} else if (strcmp(argv[1], "name") == 0) {
Tcl_Obj *objPtr;
if (sscanf(argv[2], "%d", &id) != 1) {
Tcl_AppendResult(interp, "bad command token \"", argv[2],
"\"", NULL);
return TCL_ERROR;
}
for (refPtr = firstCommandTokenRef; refPtr != NULL;
refPtr = refPtr->nextPtr) {
if (refPtr->id == id) {
break;
}
}
if (refPtr == NULL) {
Tcl_AppendResult(interp, "bad command token \"", argv[2],
"\"", NULL);
return TCL_ERROR;
}
objPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, refPtr->token, objPtr);
Tcl_AppendElement(interp,
Tcl_GetCommandName(interp, refPtr->token));
Tcl_AppendElement(interp, Tcl_GetString(objPtr));
Tcl_DecrRefCount(objPtr);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create or name", NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1259 1260 1261 1262 1263 1264 1265 |
" option script\"", NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "tracetest") == 0) {
Tcl_DStringInit(&buffer);
cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer);
| | | | | | | 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 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 |
" option script\"", NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "tracetest") == 0) {
Tcl_DStringInit(&buffer);
cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer);
result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
}
Tcl_DeleteTrace(interp, cmdTrace);
Tcl_DStringFree(&buffer);
} else if (strcmp(argv[1], "deletetest") == 0) {
/*
* Create a command trace then eval a script to check whether it is
* called. Note that this trace procedure removes itself as a further
* check of the robustness of the trace proc calling code in
* TclNRExecuteByteCode.
*/
cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceDeleteProc, NULL);
Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0);
} else if (strcmp(argv[1], "leveltest") == 0) {
Interp *iPtr = (Interp *) interp;
Tcl_DStringInit(&buffer);
cmdTrace = Tcl_CreateTrace(interp, iPtr->numLevels + 4, CmdTraceProc,
&buffer);
result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
}
Tcl_DeleteTrace(interp, cmdTrace);
Tcl_DStringFree(&buffer);
} else if (strcmp(argv[1], "resulttest") == 0) {
/* Create an object-based trace, then eval a script. This is used
* to test return codes other than TCL_OK from the trace engine.
*/
static int deleteCalled;
deleteCalled = 0;
cmdTrace = Tcl_CreateObjTrace(interp, 50000,
TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc,
&deleteCalled, ObjTraceDeleteProc);
result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0);
Tcl_DeleteTrace(interp, cmdTrace);
if (!deleteCalled) {
Tcl_AppendResult(interp, "Delete wasn't called", NULL);
return TCL_ERROR;
} else {
return result;
}
} else if (strcmp(argv[1], "doubletest") == 0) {
Tcl_Trace t1, t2;
Tcl_DStringInit(&buffer);
t1 = Tcl_CreateTrace(interp, 1, CmdTraceProc, &buffer);
t2 = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer);
result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
}
Tcl_DeleteTrace(interp, t2);
Tcl_DeleteTrace(interp, t1);
Tcl_DStringFree(&buffer);
|
| ︙ | ︙ | |||
1388 1389 1390 1391 1392 1393 1394 |
TCL_UNUSED(Tcl_Command),
TCL_UNUSED(int) /*objc*/,
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *word = Tcl_GetString(objv[0]);
if (!strcmp(word, "Error")) {
| | | 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 |
TCL_UNUSED(Tcl_Command),
TCL_UNUSED(int) /*objc*/,
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *word = Tcl_GetString(objv[0]);
if (!strcmp(word, "Error")) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(command, TCL_INDEX_NONE));
return TCL_ERROR;
} else if (!strcmp(word, "Break")) {
return TCL_BREAK;
} else if (!strcmp(word, "Continue")) {
return TCL_CONTINUE;
} else if (!strcmp(word, "Return")) {
return TCL_RETURN;
|
| ︙ | ︙ | |||
1637 1638 1639 1640 1641 1642 1643 |
static void
DelDeleteProc(
void *clientData) /* String command to evaluate. */
{
DelCmd *dPtr = (DelCmd *)clientData;
| | | 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 |
static void
DelDeleteProc(
void *clientData) /* String command to evaluate. */
{
DelCmd *dPtr = (DelCmd *)clientData;
Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, TCL_INDEX_NONE, 0);
Tcl_ResetResult(dPtr->interp);
Tcl_Free(dPtr->deleteCmd);
Tcl_Free(dPtr);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1752 1753 1754 1755 1756 1757 1758 |
TCL_EXACT, &type) != TCL_OK) {
fprintf(stderr, "bad value? %g\n", d);
return TCL_ERROR;
}
type = types[type];
if (objc > 4) {
if (strcmp(Tcl_GetString(objv[4]), "shorten")) {
| | | 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 |
TCL_EXACT, &type) != TCL_OK) {
fprintf(stderr, "bad value? %g\n", d);
return TCL_ERROR;
}
type = types[type];
if (objc > 4) {
if (strcmp(Tcl_GetString(objv[4]), "shorten")) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("bad flag", TCL_INDEX_NONE));
return TCL_ERROR;
}
type |= TCL_DD_SHORTEST;
}
str = TclDoubleDigits(d, ndigits, type, &decpt, &signum, &endPtr);
strObj = Tcl_NewStringObj(str, endPtr-str);
Tcl_Free(str);
|
| ︙ | ︙ | |||
1996 1997 1998 1999 2000 2001 2002 |
int *dstWrotePtr, /* Filled with number of bytes stored. */
int *dstCharsPtr) /* Filled with number of chars stored. */
{
int len;
TclEncoding *encodingPtr;
encodingPtr = (TclEncoding *) clientData;
| | | 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 |
int *dstWrotePtr, /* Filled with number of bytes stored. */
int *dstCharsPtr) /* Filled with number of chars stored. */
{
int len;
TclEncoding *encodingPtr;
encodingPtr = (TclEncoding *) clientData;
Tcl_EvalEx(encodingPtr->interp, encodingPtr->toUtfCmd, TCL_INDEX_NONE, TCL_EVAL_GLOBAL);
len = strlen(Tcl_GetStringResult(encodingPtr->interp));
if (len > dstLen) {
len = dstLen;
}
memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), len);
Tcl_ResetResult(encodingPtr->interp);
|
| ︙ | ︙ | |||
2028 2029 2030 2031 2032 2033 2034 |
int *dstWrotePtr, /* Filled with number of bytes stored. */
int *dstCharsPtr) /* Filled with number of chars stored. */
{
int len;
TclEncoding *encodingPtr;
encodingPtr = (TclEncoding *) clientData;
| | | 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 |
int *dstWrotePtr, /* Filled with number of bytes stored. */
int *dstCharsPtr) /* Filled with number of chars stored. */
{
int len;
TclEncoding *encodingPtr;
encodingPtr = (TclEncoding *) clientData;
Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd, TCL_INDEX_NONE, TCL_EVAL_GLOBAL);
len = strlen(Tcl_GetStringResult(encodingPtr->interp));
if (len > dstLen) {
len = dstLen;
}
memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), len);
Tcl_ResetResult(encodingPtr->interp);
|
| ︙ | ︙ | |||
2180 2181 2182 2183 2184 2185 2186 |
"queue", "delete", NULL
};
int subCmdIndex; /* Index of the chosen subcommand */
static const char *const positions[] = { /* Possible queue positions */
"head", "tail", "mark", NULL
};
int posIndex; /* Index of the chosen position */
| | | 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 |
"queue", "delete", NULL
};
int subCmdIndex; /* Index of the chosen subcommand */
static const char *const positions[] = { /* Possible queue positions */
"head", "tail", "mark", NULL
};
int posIndex; /* Index of the chosen position */
static const int posNum[] = {
/* Interpretation of the chosen position */
TCL_QUEUE_HEAD,
TCL_QUEUE_TAIL,
TCL_QUEUE_MARK
};
TestEvent *ev; /* Event to be queued */
|
| ︙ | ︙ | |||
3067 3068 3069 3070 3071 3072 3073 |
stringVar = NULL;
} else {
stringVar = (char *)Tcl_Alloc(strlen(argv[5]) + 1);
strcpy(stringVar, argv[5]);
}
}
if (argv[6][0] != 0) {
| | | 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 |
stringVar = NULL;
} else {
stringVar = (char *)Tcl_Alloc(strlen(argv[5]) + 1);
strcpy(stringVar, argv[5]);
}
}
if (argv[6][0] != 0) {
tmp = Tcl_NewStringObj(argv[6], TCL_INDEX_NONE);
if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
Tcl_DecrRefCount(tmp);
return TCL_ERROR;
}
Tcl_DecrRefCount(tmp);
}
if (argv[7][0]) {
|
| ︙ | ︙ | |||
3125 3126 3127 3128 3129 3130 3131 |
if (Tcl_GetDouble(interp, argv[14], &d) != TCL_OK) {
return TCL_ERROR;
}
floatVar = (float) d;
}
if (argv[15][0]) {
Tcl_WideInt w;
| | | 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 |
if (Tcl_GetDouble(interp, argv[14], &d) != TCL_OK) {
return TCL_ERROR;
}
floatVar = (float) d;
}
if (argv[15][0]) {
Tcl_WideInt w;
tmp = Tcl_NewStringObj(argv[15], TCL_INDEX_NONE);
if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) {
Tcl_DecrRefCount(tmp);
return TCL_ERROR;
}
Tcl_DecrRefCount(tmp);
uwideVar = (Tcl_WideUInt) w;
}
|
| ︙ | ︙ | |||
3175 3176 3177 3178 3179 3180 3181 |
} else {
stringVar = (char *)Tcl_Alloc(strlen(argv[5]) + 1);
strcpy(stringVar, argv[5]);
}
Tcl_UpdateLinkedVar(interp, "string");
}
if (argv[6][0] != 0) {
| | | 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 |
} else {
stringVar = (char *)Tcl_Alloc(strlen(argv[5]) + 1);
strcpy(stringVar, argv[5]);
}
Tcl_UpdateLinkedVar(interp, "string");
}
if (argv[6][0] != 0) {
tmp = Tcl_NewStringObj(argv[6], TCL_INDEX_NONE);
if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
Tcl_DecrRefCount(tmp);
return TCL_ERROR;
}
Tcl_DecrRefCount(tmp);
Tcl_UpdateLinkedVar(interp, "wide");
}
|
| ︙ | ︙ | |||
3242 3243 3244 3245 3246 3247 3248 |
return TCL_ERROR;
}
floatVar = (float) d;
Tcl_UpdateLinkedVar(interp, "float");
}
if (argv[15][0]) {
Tcl_WideInt w;
| | | 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 |
return TCL_ERROR;
}
floatVar = (float) d;
Tcl_UpdateLinkedVar(interp, "float");
}
if (argv[15][0]) {
Tcl_WideInt w;
tmp = Tcl_NewStringObj(argv[15], TCL_INDEX_NONE);
if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) {
Tcl_DecrRefCount(tmp);
return TCL_ERROR;
}
Tcl_DecrRefCount(tmp);
uwideVar = (Tcl_WideUInt) w;
Tcl_UpdateLinkedVar(interp, "uwide");
|
| ︙ | ︙ | |||
3349 3350 3351 3352 3353 3354 3355 |
i++;
}
if (Tcl_GetIndexFromObj(interp, objv[i++], LinkType, "type", 0,
&typeIndex) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[i++], &size) == TCL_ERROR) {
| | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 |
i++;
}
if (Tcl_GetIndexFromObj(interp, objv[i++], LinkType, "type", 0,
&typeIndex) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[i++], &size) == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong size value", TCL_INDEX_NONE));
return TCL_ERROR;
}
name = Tcl_GetString(objv[i++]);
/*
* If no address is given request one in the underlying function
*/
if (i < objc) {
if (Tcl_GetWideIntFromObj(interp, objv[i], &addr) == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"wrong address value", TCL_INDEX_NONE));
return TCL_ERROR;
}
} else {
addr = 0;
}
return Tcl_LinkArray(interp, name, INT2PTR(addr),
LinkTypes[typeIndex] | readonly, size);
}
return TCL_OK;
wrongArgs:
Tcl_WrongNumArgs(interp, 2, objv, "?-readonly? type size name ?address?");
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TestlistrepCmd --
*
* This function is invoked to generate a list object with a specific
* internal representation.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestlistrepCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
/* Subcommands supported by this command */
const char* subcommands[] = {
"new",
"describe",
"config",
"validate",
NULL
};
enum {
LISTREP_NEW,
LISTREP_DESCRIBE,
LISTREP_CONFIG,
LISTREP_VALIDATE
} cmdIndex;
Tcl_Obj *resultObj = NULL;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(
interp, objv[1], subcommands, "command", 0, &cmdIndex)
!= TCL_OK) {
return TCL_ERROR;
}
switch (cmdIndex) {
case LISTREP_NEW:
if (objc < 3 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv, "length ?leadSpace endSpace?");
return TCL_ERROR;
} else {
int length;
int leadSpace = 0;
int endSpace = 0;
if (Tcl_GetIntFromObj(interp, objv[2], &length) != TCL_OK) {
return TCL_ERROR;
}
if (objc > 3) {
if (Tcl_GetIntFromObj(interp, objv[3], &leadSpace) != TCL_OK) {
return TCL_ERROR;
}
if (objc > 4) {
if (Tcl_GetIntFromObj(interp, objv[4], &endSpace)
!= TCL_OK) {
return TCL_ERROR;
}
}
}
resultObj = TclListTestObj(length, leadSpace, endSpace);
}
break;
case LISTREP_DESCRIBE:
#define APPEND_FIELD(targetObj_, structPtr_, fld_) \
do { \
Tcl_ListObjAppendElement( \
interp, (targetObj_), Tcl_NewStringObj(#fld_, TCL_INDEX_NONE)); \
Tcl_ListObjAppendElement( \
interp, (targetObj_), Tcl_NewWideIntObj((structPtr_)->fld_)); \
} while (0)
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "object");
return TCL_ERROR;
} else {
Tcl_Obj **objs;
ListSizeT nobjs;
ListRep listRep;
Tcl_Obj *listRepObjs[4];
/* Force list representation */
if (Tcl_ListObjGetElements(interp, objv[2], &nobjs, &objs) != TCL_OK) {
return TCL_ERROR;
}
ListObjGetRep(objv[2], &listRep);
listRepObjs[0] = Tcl_NewStringObj("store", TCL_INDEX_NONE);
listRepObjs[1] = Tcl_NewListObj(12, NULL);
Tcl_ListObjAppendElement(
interp, listRepObjs[1], Tcl_NewStringObj("memoryAddress", TCL_INDEX_NONE));
Tcl_ListObjAppendElement(
interp, listRepObjs[1], Tcl_ObjPrintf("%p", listRep.storePtr));
APPEND_FIELD(listRepObjs[1], listRep.storePtr, firstUsed);
APPEND_FIELD(listRepObjs[1], listRep.storePtr, numUsed);
APPEND_FIELD(listRepObjs[1], listRep.storePtr, numAllocated);
APPEND_FIELD(listRepObjs[1], listRep.storePtr, refCount);
APPEND_FIELD(listRepObjs[1], listRep.storePtr, flags);
if (listRep.spanPtr) {
listRepObjs[2] = Tcl_NewStringObj("span", TCL_INDEX_NONE);
listRepObjs[3] = Tcl_NewListObj(8, NULL);
Tcl_ListObjAppendElement(interp,
listRepObjs[3],
Tcl_NewStringObj("memoryAddress", TCL_INDEX_NONE));
Tcl_ListObjAppendElement(
interp, listRepObjs[3], Tcl_ObjPrintf("%p", listRep.spanPtr));
APPEND_FIELD(listRepObjs[3], listRep.spanPtr, spanStart);
APPEND_FIELD(
listRepObjs[3], listRep.spanPtr, spanLength);
APPEND_FIELD(listRepObjs[3], listRep.spanPtr, refCount);
}
resultObj = Tcl_NewListObj(listRep.spanPtr ? 4 : 2, listRepObjs);
}
#undef APPEND_FIELD
break;
case LISTREP_CONFIG:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, "object");
return TCL_ERROR;
}
resultObj = Tcl_NewListObj(2, NULL);
Tcl_ListObjAppendElement(
NULL, resultObj, Tcl_NewStringObj("LIST_SPAN_THRESHOLD", TCL_INDEX_NONE));
Tcl_ListObjAppendElement(
NULL, resultObj, Tcl_NewWideIntObj(LIST_SPAN_THRESHOLD));
break;
case LISTREP_VALIDATE:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "object");
return TCL_ERROR;
}
TclListObjValidate(interp, objv[2]); /* Panics if invalid */
resultObj = Tcl_NewObj();
break;
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestlocaleCmd --
*
* This procedure implements the "testlocale" command. It is used
|
| ︙ | ︙ | |||
3433 3434 3435 3436 3437 3438 3439 |
if (objc == 3) {
locale = Tcl_GetString(objv[2]);
} else {
locale = NULL;
}
locale = setlocale(lcTypes[index], locale);
if (locale) {
| | | 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 |
if (objc == 3) {
locale = Tcl_GetString(objv[2]);
} else {
locale = NULL;
}
locale = setlocale(lcTypes[index], locale);
if (locale) {
Tcl_SetStringObj(Tcl_GetObjResult(interp), locale, TCL_INDEX_NONE);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3655 3656 3657 3658 3659 3660 3661 | typeString = "operator"; break; default: typeString = "??"; break; } Tcl_ListObjAppendElement(NULL, objPtr, | | | | 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 |
typeString = "operator";
break;
default:
typeString = "??";
break;
}
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(typeString, TCL_INDEX_NONE));
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(tokenPtr->start, tokenPtr->size));
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewWideIntObj(tokenPtr->numComponents));
}
Tcl_ListObjAppendElement(NULL, objPtr,
parsePtr->commandStart ?
Tcl_NewStringObj(parsePtr->commandStart + parsePtr->commandSize,
TCL_INDEX_NONE) : Tcl_NewObj());
}
/*
*----------------------------------------------------------------------
*
* TestparsevarObjCmd --
*
|
| ︙ | ︙ | |||
3983 3984 3985 3986 3987 3988 3989 |
if (objc > 2 && (cflags®_EXPECT) && indices) {
const char *varName;
const char *value;
size_t start, end;
char resinfo[TCL_INTEGER_SPACE * 2];
varName = Tcl_GetString(objv[2]);
| | | 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 |
if (objc > 2 && (cflags®_EXPECT) && indices) {
const char *varName;
const char *value;
size_t start, end;
char resinfo[TCL_INTEGER_SPACE * 2];
varName = Tcl_GetString(objv[2]);
TclRegExpRangeUniChar(regExpr, TCL_INDEX_NONE, &start, &end);
sprintf(resinfo, "%" TCL_Z_MODIFIER "d %" TCL_Z_MODIFIER "d", start, (end-1));
value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
varName, "\"", NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
4305 4306 4307 4308 4309 4310 4311 | * This procedure implements the "teststaticlibrary" command. * It is used to test the procedure Tcl_StaticLibrary. * * Results: * A standard Tcl result. * * Side effects: | | | 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 | * This procedure implements the "teststaticlibrary" command. * It is used to test the procedure Tcl_StaticLibrary. * * Results: * A standard Tcl result. * * Side effects: * When the packge given by argv[1] is loaded into an interpreter, * variable "x" in that interpreter is set to "loaded". * *---------------------------------------------------------------------- */ static int TeststaticlibraryCmd( |
| ︙ | ︙ | |||
4558 4559 4560 4561 4562 4563 4564 |
if (strcmp(argv[1], "cmd") == 0) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" cmd script", NULL);
return TCL_ERROR;
}
if (interp2 != NULL) {
| | | 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 |
if (strcmp(argv[1], "cmd") == 0) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" cmd script", NULL);
return TCL_ERROR;
}
if (interp2 != NULL) {
code = Tcl_EvalEx(interp2, argv[2], TCL_INDEX_NONE, TCL_EVAL_GLOBAL);
Tcl_SetObjResult(interp, Tcl_GetObjResult(interp2));
return code;
} else {
Tcl_AppendResult(interp,
"called \"testfevent code\" before \"testfevent create\"",
NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
4853 4854 4855 4856 4857 4858 4859 |
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000);
Tcl_Free(objv);
/* TclGetString 100000 times */
fprintf(stderr, "Tcl_GetStringFromObj of \"12345\" 100000 times\n");
| | | 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 |
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000);
Tcl_Free(objv);
/* TclGetString 100000 times */
fprintf(stderr, "Tcl_GetStringFromObj of \"12345\" 100000 times\n");
objPtr = Tcl_NewStringObj("12345", TCL_INDEX_NONE);
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
(void) TclGetString(objPtr);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_GetStringFromObj of \"12345\"\n",
|
| ︙ | ︙ | |||
5117 5118 5119 5120 5121 5122 5123 |
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "value length");
return TCL_ERROR;
}
if (TCL_OK != Tcl_GetIntFromObj(interp, objv[2], &n)) {
return TCL_ERROR;
}
| > | | < < | > > > | | 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 |
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "value length");
return TCL_ERROR;
}
if (TCL_OK != Tcl_GetIntFromObj(interp, objv[2], &n)) {
return TCL_ERROR;
}
obj = objv[1];
if (Tcl_IsShared(obj)) {
obj = Tcl_DuplicateObj(obj);
}
if (Tcl_SetByteArrayLength(obj, n) == NULL) {
if (obj != objv[1]) {
Tcl_DecrRefCount(obj);
}
Tcl_AppendResult(interp, "expected bytes", NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, obj);
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
5322 5323 5324 5325 5326 5327 5328 |
Tcl_SetResult(interp, buf, TCL_DYNAMIC);
break;
}
case RESULT_DYNAMIC:
Tcl_SetResult(interp, (char *)"dynamic result", TestsaveresultFree);
break;
case RESULT_OBJECT:
| | | | 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 |
Tcl_SetResult(interp, buf, TCL_DYNAMIC);
break;
}
case RESULT_DYNAMIC:
Tcl_SetResult(interp, (char *)"dynamic result", TestsaveresultFree);
break;
case RESULT_OBJECT:
objPtr = Tcl_NewStringObj("object result", TCL_INDEX_NONE);
Tcl_SetObjResult(interp, objPtr);
break;
}
Tcl_SaveResult(interp, &state);
if (index == RESULT_OBJECT) {
result = Tcl_EvalObjEx(interp, objv[2], 0);
} else {
result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), TCL_INDEX_NONE, 0);
}
if (discard) {
Tcl_DiscardResult(&state);
} else {
Tcl_RestoreResult(interp, &state);
result = TCL_OK;
|
| ︙ | ︙ | |||
5581 5582 5583 5584 5585 5586 5587 |
} else {
statePtr = NULL;
chan = NULL;
}
if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerror", len) == 0)) {
| | | | 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 |
} else {
statePtr = NULL;
chan = NULL;
}
if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerror", len) == 0)) {
Tcl_Obj *msg = Tcl_NewStringObj(argv[3], TCL_INDEX_NONE);
Tcl_IncrRefCount(msg);
Tcl_SetChannelError(chan, msg);
Tcl_DecrRefCount(msg);
Tcl_GetChannelError(chan, &msg);
Tcl_SetObjResult(interp, msg);
Tcl_DecrRefCount(msg);
return TCL_OK;
}
if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerrorinterp", len) == 0)) {
Tcl_Obj *msg = Tcl_NewStringObj(argv[3], TCL_INDEX_NONE);
Tcl_IncrRefCount(msg);
Tcl_SetChannelErrorInterp(interp, msg);
Tcl_DecrRefCount(msg);
Tcl_GetChannelErrorInterp(interp, &msg);
Tcl_SetObjResult(interp, msg);
|
| ︙ | ︙ | |||
5942 5943 5944 5945 5946 5947 5948 |
if (strcmp(argv[3], "-command") != 0) {
Tcl_AppendResult(interp, "bad argument \"", argv[3],
"\": should be \"-command\"", NULL);
return TCL_ERROR;
}
return TclChannelTransform(interp, chan,
| | | 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 |
if (strcmp(argv[3], "-command") != 0) {
Tcl_AppendResult(interp, "bad argument \"", argv[3],
"\": should be \"-command\"", NULL);
return TCL_ERROR;
}
return TclChannelTransform(interp, chan,
Tcl_NewStringObj(argv[4], TCL_INDEX_NONE));
}
if ((cmdName[0] == 'u') && (strncmp(cmdName, "unstack", len) == 0)) {
/*
* Syntax: unstack channel
*/
|
| ︙ | ︙ | |||
6033 6034 6035 6036 6037 6038 6039 | esPtr = (EventScriptRecord *)Tcl_Alloc(sizeof(EventScriptRecord)); esPtr->nextPtr = statePtr->scriptRecordPtr; statePtr->scriptRecordPtr = esPtr; esPtr->chanPtr = chanPtr; esPtr->interp = interp; esPtr->mask = mask; | | | 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 |
esPtr = (EventScriptRecord *)Tcl_Alloc(sizeof(EventScriptRecord));
esPtr->nextPtr = statePtr->scriptRecordPtr;
statePtr->scriptRecordPtr = esPtr;
esPtr->chanPtr = chanPtr;
esPtr->interp = interp;
esPtr->mask = mask;
esPtr->scriptPtr = Tcl_NewStringObj(argv[4], TCL_INDEX_NONE);
Tcl_IncrRefCount(esPtr->scriptPtr);
Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
TclChannelEventScriptInvoker, esPtr);
return TCL_OK;
}
|
| ︙ | ︙ | |||
6100 6101 6102 6103 6104 6105 6106 |
}
resultListPtr = Tcl_GetObjResult(interp);
for (esPtr = statePtr->scriptRecordPtr;
esPtr != NULL;
esPtr = esPtr->nextPtr) {
if (esPtr->mask) {
Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
| | | | 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 |
}
resultListPtr = Tcl_GetObjResult(interp);
for (esPtr = statePtr->scriptRecordPtr;
esPtr != NULL;
esPtr = esPtr->nextPtr) {
if (esPtr->mask) {
Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
(esPtr->mask == TCL_READABLE) ? "readable" : "writable", TCL_INDEX_NONE));
} else {
Tcl_ListObjAppendElement(interp, resultListPtr,
Tcl_NewStringObj("none", TCL_INDEX_NONE));
}
Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr);
}
Tcl_SetObjResult(interp, resultListPtr);
return TCL_OK;
}
|
| ︙ | ︙ | |||
6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestSocketCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter for result. */
int argc, /* Count of additional args. */
const char **argv) /* Additional arg strings. */
{
| > > > > | 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#define TCP_ASYNC_TEST_MODE (1<<8) /* Async testing activated. Do not
* automatically continue connection
* process. */
static int
TestSocketCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter for result. */
int argc, /* Count of additional args. */
const char **argv) /* Additional arg strings. */
{
|
| ︙ | ︙ | |||
6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 |
}
cmdName = argv[1];
len = strlen(cmdName);
if ((cmdName[0] == 't') && (strncmp(cmdName, "testflags", len) == 0)) {
Tcl_Channel hChannel;
int modePtr;
TcpState *statePtr;
/* Set test value in the socket driver
*/
/* Check for argument "channel name"
*/
if (argc < 4) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
| > | 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 |
}
cmdName = argv[1];
len = strlen(cmdName);
if ((cmdName[0] == 't') && (strncmp(cmdName, "testflags", len) == 0)) {
Tcl_Channel hChannel;
int modePtr;
int testMode;
TcpState *statePtr;
/* Set test value in the socket driver
*/
/* Check for argument "channel name"
*/
if (argc < 4) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
| ︙ | ︙ | |||
6235 6236 6237 6238 6239 6240 6241 |
}
statePtr = (TcpState *)Tcl_GetChannelInstanceData(hChannel);
if ( NULL == statePtr) {
Tcl_AppendResult(interp, "No channel instance data:", argv[2],
NULL);
return TCL_ERROR;
}
| > > > > | > > > | 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 |
}
statePtr = (TcpState *)Tcl_GetChannelInstanceData(hChannel);
if ( NULL == statePtr) {
Tcl_AppendResult(interp, "No channel instance data:", argv[2],
NULL);
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[3], &testMode) != TCL_OK) {
return TCL_ERROR;
}
if (testMode) {
statePtr->flags |= TCP_ASYNC_TEST_MODE;
} else {
statePtr->flags &= ~TCP_ASYNC_TEST_MODE;
}
return TCL_OK;
}
Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be "
"testflags", NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
6312 6313 6314 6315 6316 6317 6318 |
*----------------------------------------------------------------------
*/
static int
TestWrongNumArgsObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | | < < | < < < | > | 6527 6528 6529 6530 6531 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 6543 6544 6545 6546 6547 6548 6549 6550 6551 6552 6553 6554 6555 6556 6557 6558 6559 6560 6561 6562 6563 6564 |
*----------------------------------------------------------------------
*/
static int
TestWrongNumArgsObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
size_t objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
size_t i, length;
const char *msg;
if (objc + 1 < 4) {
goto insufArgs;
}
if (Tcl_GetIntForIndex(interp, objv[1], TCL_INDEX_NONE, &i) != TCL_OK) {
return TCL_ERROR;
}
msg = Tcl_GetStringFromObj(objv[2], &length);
if (length == 0) {
msg = NULL;
}
if (i > objc - 3) {
/*
* Asked for more arguments than were given.
*/
insufArgs:
Tcl_AppendResult(interp, "insufficient arguments", NULL);
return TCL_ERROR;
}
Tcl_WrongNumArgs(interp, i, &(objv[3]), msg);
return TCL_OK;
}
|
| ︙ | ︙ | |||
6450 6451 6452 6453 6454 6455 6456 |
if (boolVal) {
res = Tcl_FSRegister(interp, &testReportingFilesystem);
msg = (res == TCL_OK) ? "registered" : "failed";
} else {
res = Tcl_FSUnregister(&testReportingFilesystem);
msg = (res == TCL_OK) ? "unregistered" : "failed";
}
| | | 6661 6662 6663 6664 6665 6666 6667 6668 6669 6670 6671 6672 6673 6674 6675 |
if (boolVal) {
res = Tcl_FSRegister(interp, &testReportingFilesystem);
msg = (res == TCL_OK) ? "registered" : "failed";
} else {
res = Tcl_FSUnregister(&testReportingFilesystem);
msg = (res == TCL_OK) ? "unregistered" : "failed";
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , TCL_INDEX_NONE));
return res;
}
static int
TestReportInFilesystem(
Tcl_Obj *pathPtr,
void **clientDataPtr)
|
| ︙ | ︙ | |||
6532 6533 6534 6535 6536 6537 6538 |
if (interp == NULL) {
/* This is bad, but not much we can do about it */
} else {
Tcl_Obj *savedResult;
Tcl_DString ds;
Tcl_DStringInit(&ds);
| | | | 6743 6744 6745 6746 6747 6748 6749 6750 6751 6752 6753 6754 6755 6756 6757 6758 6759 6760 6761 6762 6763 6764 6765 6766 6767 6768 6769 6770 |
if (interp == NULL) {
/* This is bad, but not much we can do about it */
} else {
Tcl_Obj *savedResult;
Tcl_DString ds;
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, "lappend filesystemReport ", TCL_INDEX_NONE);
Tcl_DStringStartSublist(&ds);
Tcl_DStringAppendElement(&ds, cmd);
if (path != NULL) {
Tcl_DStringAppendElement(&ds, Tcl_GetString(path));
}
if (arg2 != NULL) {
Tcl_DStringAppendElement(&ds, Tcl_GetString(arg2));
}
Tcl_DStringEndSublist(&ds);
savedResult = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(savedResult);
Tcl_SetObjResult(interp, Tcl_NewObj());
Tcl_EvalEx(interp, Tcl_DStringValue(&ds), TCL_INDEX_NONE, 0);
Tcl_DStringFree(&ds);
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, savedResult);
Tcl_DecrRefCount(savedResult);
}
}
|
| ︙ | ︙ | |||
6821 6822 6823 6824 6825 6826 6827 |
if (boolVal) {
res = Tcl_FSRegister(interp, &simpleFilesystem);
msg = (res == TCL_OK) ? "registered" : "failed";
} else {
res = Tcl_FSUnregister(&simpleFilesystem);
msg = (res == TCL_OK) ? "unregistered" : "failed";
}
| | | 7032 7033 7034 7035 7036 7037 7038 7039 7040 7041 7042 7043 7044 7045 7046 |
if (boolVal) {
res = Tcl_FSRegister(interp, &simpleFilesystem);
msg = (res == TCL_OK) ? "registered" : "failed";
} else {
res = Tcl_FSUnregister(&simpleFilesystem);
msg = (res == TCL_OK) ? "unregistered" : "failed";
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , TCL_INDEX_NONE));
return res;
}
/*
* Treats a file name 'simplefs:/foo' by using the file 'foo' in the current
* (native) directory.
*/
|
| ︙ | ︙ | |||
6848 6849 6850 6851 6852 6853 6854 |
str = Tcl_GetStringFromObj(pathPtr, &len);
if (len < 10 || strncmp(str, "simplefs:/", 10)) {
/* Probably shouldn't ever reach here */
Tcl_IncrRefCount(pathPtr);
return pathPtr;
}
| | | 7059 7060 7061 7062 7063 7064 7065 7066 7067 7068 7069 7070 7071 7072 7073 |
str = Tcl_GetStringFromObj(pathPtr, &len);
if (len < 10 || strncmp(str, "simplefs:/", 10)) {
/* Probably shouldn't ever reach here */
Tcl_IncrRefCount(pathPtr);
return pathPtr;
}
origPtr = Tcl_NewStringObj(str+10, TCL_INDEX_NONE);
Tcl_IncrRefCount(origPtr);
return origPtr;
}
static int
SimpleMatchInDirectory(
Tcl_Interp *interp, /* Interpreter for error
|
| ︙ | ︙ | |||
6948 6949 6950 6951 6952 6953 6954 |
static Tcl_Obj *
SimpleListVolumes(void)
{
/* Add one new volume */
Tcl_Obj *retVal;
| | | 7159 7160 7161 7162 7163 7164 7165 7166 7167 7168 7169 7170 7171 7172 7173 |
static Tcl_Obj *
SimpleListVolumes(void)
{
/* Add one new volume */
Tcl_Obj *retVal;
retVal = Tcl_NewStringObj("simplefs:/", TCL_INDEX_NONE);
Tcl_IncrRefCount(retVal);
return retVal;
}
/*
* Used to check operations of Tcl_UtfNext.
*
|
| ︙ | ︙ | |||
6977 6978 6979 6980 6981 6982 6983 |
static const char tobetested[] = "A\xA0\xC0\xC1\xC2\xD0\xE0\xE8\xF2\xF7\xF8\xFE\xFF";
const char *p = tobetested;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?-bytestring? bytes");
return TCL_ERROR;
}
| | < | | 7188 7189 7190 7191 7192 7193 7194 7195 7196 7197 7198 7199 7200 7201 7202 7203 7204 |
static const char tobetested[] = "A\xA0\xC0\xC1\xC2\xD0\xE0\xE8\xF2\xF7\xF8\xFE\xFF";
const char *p = tobetested;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?-bytestring? bytes");
return TCL_ERROR;
}
bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
if (numBytes + 4U > sizeof(buffer)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"testutfnext\" can only handle %" TCL_Z_MODIFIER "u bytes",
sizeof(buffer) - 4));
return TCL_ERROR;
}
memcpy(buffer + 1, bytes, numBytes);
|
| ︙ | ︙ | |||
7037 7038 7039 7040 7041 7042 7043 |
const char *result;
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "bytes ?offset?");
return TCL_ERROR;
}
| | < | 7247 7248 7249 7250 7251 7252 7253 7254 7255 7256 7257 7258 7259 7260 7261 |
const char *result;
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "bytes ?offset?");
return TCL_ERROR;
}
bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
if (objc == 3) {
if (TCL_OK != Tcl_GetIntForIndex(interp, objv[2], numBytes, &offset)) {
return TCL_ERROR;
}
if (offset == TCL_INDEX_NONE) {
offset = 0;
|
| ︙ | ︙ | |||
7070 7071 7072 7073 7074 7075 7076 |
TestNumUtfCharsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc > 1) {
| | | < | 7279 7280 7281 7282 7283 7284 7285 7286 7287 7288 7289 7290 7291 7292 7293 7294 |
TestNumUtfCharsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc > 1) {
size_t numBytes, len, limit = TCL_INDEX_NONE;
const char *bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
if (objc > 2) {
if (Tcl_GetIntForIndex(interp, objv[2], numBytes, &limit) != TCL_OK) {
return TCL_ERROR;
}
if (limit > numBytes + 1) {
limit = numBytes + 1;
|
| ︙ | ︙ | |||
7105 7106 7107 7108 7109 7110 7111 |
{
if (objc > 1) {
int len = -1;
if (objc > 2) {
(void) Tcl_GetIntFromObj(interp, objv[2], &len);
}
| | | 7313 7314 7315 7316 7317 7318 7319 7320 7321 7322 7323 7324 7325 7326 7327 |
{
if (objc > 1) {
int len = -1;
if (objc > 2) {
(void) Tcl_GetIntFromObj(interp, objv[2], &len);
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindFirst(Tcl_GetString(objv[1]), len), TCL_INDEX_NONE));
}
return TCL_OK;
}
/*
* Used to check correct operation of Tcl_UtfFindLast
*/
|
| ︙ | ︙ | |||
7127 7128 7129 7130 7131 7132 7133 |
{
if (objc > 1) {
int len = -1;
if (objc > 2) {
(void) Tcl_GetIntFromObj(interp, objv[2], &len);
}
| | | 7335 7336 7337 7338 7339 7340 7341 7342 7343 7344 7345 7346 7347 7348 7349 |
{
if (objc > 1) {
int len = -1;
if (objc > 2) {
(void) Tcl_GetIntFromObj(interp, objv[2], &len);
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindLast(Tcl_GetString(objv[1]), len), TCL_INDEX_NONE));
}
return TCL_OK;
}
static int
TestGetIntForIndexCmd(
TCL_UNUSED(void *),
|
| ︙ | ︙ | |||
7205 7206 7207 7208 7209 7210 7211 |
}
if (Tcl_GetIntFromObj(interp, objv[1], &index) != TCL_OK) {
return TCL_ERROR;
}
status = TclWinCPUID(index, regs);
if (status != TCL_OK) {
Tcl_SetObjResult(interp,
| | | 7413 7414 7415 7416 7417 7418 7419 7420 7421 7422 7423 7424 7425 7426 7427 |
}
if (Tcl_GetIntFromObj(interp, objv[1], &index) != TCL_OK) {
return TCL_ERROR;
}
status = TclWinCPUID(index, regs);
if (status != TCL_OK) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("operation not available", TCL_INDEX_NONE));
return status;
}
for (i=0 ; i<4 ; ++i) {
regsObjs[i] = Tcl_NewWideIntObj(regs[i]);
}
Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs));
return TCL_OK;
|
| ︙ | ︙ | |||
7251 7252 7253 7254 7255 7256 7257 |
return TCL_ERROR;
}
for (i=0 ; i<limit ; i++) {
hPtr = Tcl_CreateHashEntry(&hash, INT2PTR(i), &isNew);
if (!isNew) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
| | | | | 7459 7460 7461 7462 7463 7464 7465 7466 7467 7468 7469 7470 7471 7472 7473 7474 7475 7476 7477 7478 7479 7480 7481 7482 7483 7484 7485 7486 7487 7488 7489 7490 7491 7492 7493 7494 7495 7496 |
return TCL_ERROR;
}
for (i=0 ; i<limit ; i++) {
hPtr = Tcl_CreateHashEntry(&hash, INT2PTR(i), &isNew);
if (!isNew) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem", TCL_INDEX_NONE);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
Tcl_SetHashValue(hPtr, INT2PTR(i+42));
}
if (hash.numEntries != (size_t)limit) {
Tcl_AppendResult(interp, "unexpected maximal size", NULL);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
for (i=0 ; i<limit ; i++) {
hPtr = Tcl_FindHashEntry(&hash, (char *) INT2PTR(i));
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
Tcl_AppendToObj(Tcl_GetObjResult(interp)," lookup problem", TCL_INDEX_NONE);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
if (PTR2INT(Tcl_GetHashValue(hPtr)) != i+42) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
Tcl_AppendToObj(Tcl_GetObjResult(interp)," value problem", TCL_INDEX_NONE);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
Tcl_DeleteHashEntry(hPtr);
}
if (hash.numEntries != 0) {
|
| ︙ | ︙ | |||
7456 7457 7458 7459 7460 7461 7462 |
/*
* Set the start of the error message as obj result; it will be cleared at
* the end if no errors were found.
*/
Tcl_SetObjResult(interp,
| | | | | 7664 7665 7666 7667 7668 7669 7670 7671 7672 7673 7674 7675 7676 7677 7678 7679 7680 7681 7682 7683 7684 7685 7686 |
/*
* Set the start of the error message as obj result; it will be cleared at
* the end if no errors were found.
*/
Tcl_SetObjResult(interp,
Tcl_NewStringObj("Tcl_ConcatObj is unsafe:", TCL_INDEX_NONE));
emptyPtr = Tcl_NewObj();
list1Ptr = Tcl_NewStringObj("foo bar sum", TCL_INDEX_NONE);
Tcl_ListObjLength(NULL, list1Ptr, &len);
Tcl_InvalidateStringRep(list1Ptr);
list2Ptr = Tcl_NewStringObj("eeny meeny", TCL_INDEX_NONE);
Tcl_ListObjLength(NULL, list2Ptr, &len);
Tcl_InvalidateStringRep(list2Ptr);
/*
* Verify that concat'ing a list obj with one or more empty strings does
* return a fresh Tcl_Obj (see also [Bug 2055782]).
*/
|
| ︙ | ︙ | |||
8017 8018 8019 8020 8021 8022 8023 |
return var;
}
static int
InterpCompiledVarResolver(
TCL_UNUSED(Tcl_Interp *),
const char *name,
| | | | 8225 8226 8227 8228 8229 8230 8231 8232 8233 8234 8235 8236 8237 8238 8239 8240 8241 8242 8243 8244 8245 8246 8247 8248 8249 |
return var;
}
static int
InterpCompiledVarResolver(
TCL_UNUSED(Tcl_Interp *),
const char *name,
TCL_UNUSED(size_t) /*length*/,
TCL_UNUSED(Tcl_Namespace *),
Tcl_ResolvedVarInfo **rPtr)
{
if (*name == 'T') {
MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *)Tcl_Alloc(sizeof(MyResolvedVarInfo));
resVarInfo->vInfo.fetchProc = MyCompiledVarFetch;
resVarInfo->vInfo.deleteProc = MyCompiledVarFree;
resVarInfo->var = NULL;
resVarInfo->nameObj = Tcl_NewStringObj(name, TCL_INDEX_NONE);
Tcl_IncrRefCount(resVarInfo->nameObj);
*rPtr = &resVarInfo->vInfo;
return TCL_OK;
}
return TCL_CONTINUE;
}
|
| ︙ | ︙ | |||
8077 8078 8079 8080 8081 8082 8083 |
Tcl_AppendResult(interp, "could not remove the resolver scheme",
NULL);
return TCL_ERROR;
}
}
return TCL_OK;
}
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 8285 8286 8287 8288 8289 8290 8291 8292 8293 8294 8295 8296 8297 8298 8299 8300 8301 8302 8303 8304 8305 8306 8307 8308 8309 8310 8311 8312 8313 8314 8315 8316 8317 8318 8319 8320 8321 8322 8323 8324 8325 8326 8327 8328 8329 8330 8331 8332 8333 8334 8335 8336 8337 8338 8339 8340 8341 8342 8343 8344 8345 8346 8347 8348 8349 8350 8351 8352 8353 8354 8355 8356 8357 8358 8359 8360 8361 8362 8363 8364 8365 8366 8367 8368 8369 8370 8371 8372 8373 8374 8375 8376 8377 8378 8379 8380 |
Tcl_AppendResult(interp, "could not remove the resolver scheme",
NULL);
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
*------------------------------------------------------------------------
*
* TestApplyLambdaObjCmd --
*
* Implements the Tcl command testapplylambda. This tests the apply
* implementation handling of a lambda where the lambda has a list
* internal representation where the second element's internal
* representation is already a byte code object.
*
* Results:
* TCL_OK - Success. Caller should check result is 42
* TCL_ERROR - Error.
*
* Side effects:
* In the presence of the apply bug, may panic. Otherwise
* Interpreter result holds result or error message.
*
*------------------------------------------------------------------------
*/
int TestApplyLambdaObjCmd (
TCL_UNUSED(void*),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int), /* objc. */
TCL_UNUSED(Tcl_Obj *const *)) /* objv. */
{
Tcl_Obj *lambdaObjs[2];
Tcl_Obj *evalObjs[2];
Tcl_Obj *lambdaObj;
int result;
/* Create a lambda {{} {set a 42}} */
lambdaObjs[0] = Tcl_NewObj(); /* No parameters */
lambdaObjs[1] = Tcl_NewStringObj("set a 42", TCL_INDEX_NONE); /* Body */
lambdaObj = Tcl_NewListObj(2, lambdaObjs);
Tcl_IncrRefCount(lambdaObj);
/* Create the command "apply {{} {set a 42}" */
evalObjs[0] = Tcl_NewStringObj("apply", TCL_INDEX_NONE);
Tcl_IncrRefCount(evalObjs[0]);
/*
* NOTE: IMPORTANT TO EXHIBIT THE BUG. We duplicate the lambda because
* it will get shimmered to a Lambda internal representation but we
* want to hold on to our list representation.
*/
evalObjs[1] = Tcl_DuplicateObj(lambdaObj);
Tcl_IncrRefCount(evalObjs[1]);
/* Evaluate it */
result = Tcl_EvalObjv(interp, 2, evalObjs, TCL_EVAL_GLOBAL);
if (result != TCL_OK) {
Tcl_DecrRefCount(evalObjs[0]);
Tcl_DecrRefCount(evalObjs[1]);
return result;
}
/*
* So far so good. At this point,
* - evalObjs[1] has an internal representation of Lambda
* - lambdaObj[1] ({set a 42}) has been shimmered to
* an internal representation of ByteCode.
*/
Tcl_DecrRefCount(evalObjs[1]); /* Don't need this anymore */
/*
* The bug trigger. Repeating the command but:
* - we are calling apply with a lambda that is a list (as BEFORE),
* BUT
* - The body of the lambda (lambdaObjs[1]) ALREADY has internal
* representation of ByteCode and thus will not be compiled again
*/
evalObjs[1] = lambdaObj; /* lambdaObj already has a ref count so
no need for IncrRef */
result = Tcl_EvalObjv(interp, 2, evalObjs, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(evalObjs[0]);
Tcl_DecrRefCount(lambdaObj);
return result;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
* indent-tabs-mode: nil
* End:
*/
|
Changes to generic/tclTestObj.c.
| ︙ | ︙ | |||
1151 1152 1153 1154 1155 1156 1157 |
Tcl_WideInt length;
#define MAX_STRINGS 11
const char *string, *strings[MAX_STRINGS+1];
String *strPtr;
Tcl_Obj **varPtr;
static const char *const options[] = {
"append", "appendstrings", "get", "get2", "length", "length2",
| | | 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 |
Tcl_WideInt length;
#define MAX_STRINGS 11
const char *string, *strings[MAX_STRINGS+1];
String *strPtr;
Tcl_Obj **varPtr;
static const char *const options[] = {
"append", "appendstrings", "get", "get2", "length", "length2",
"set", "set2", "setlength", "maxchars", "range", "appendself",
"appendself2", NULL
};
if (objc < 3) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
|
| ︙ | ︙ | |||
1254 1255 1256 1257 1258 1259 1260 |
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
| | | 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 |
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
length = strPtr->allocated;
} else {
length = -1;
}
Tcl_SetWideIntObj(Tcl_GetObjResult(interp), length);
break;
case 6: /* set */
if (objc != 4) {
|
| ︙ | ︙ | |||
1314 1315 1316 1317 1318 1319 1320 |
strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
length = strPtr->maxChars;
} else {
length = -1;
}
Tcl_SetWideIntObj(Tcl_GetObjResult(interp), length);
break;
| > > > > > > > > > > > > | | 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 |
strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
length = strPtr->maxChars;
} else {
length = -1;
}
Tcl_SetWideIntObj(Tcl_GetObjResult(interp), length);
break;
case 10: { /* range */
Tcl_WideInt first, last;
if (objc != 5) {
goto wrongNumArgs;
}
if ((Tcl_GetWideIntFromObj(interp, objv[3], &first) != TCL_OK)
|| (Tcl_GetWideIntFromObj(interp, objv[4], &last) != TCL_OK)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_GetRange(varPtr[varIndex], first, last));
break;
}
case 11: /* appendself */
if (objc != 4) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varPtr, varIndex, Tcl_NewObj());
}
|
| ︙ | ︙ | |||
1345 1346 1347 1348 1349 1350 1351 | "index value out of range", -1)); return TCL_ERROR; } Tcl_AppendToObj(varPtr[varIndex], string + length, size - length); Tcl_SetObjResult(interp, varPtr[varIndex]); break; | | | 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 |
"index value out of range", -1));
return TCL_ERROR;
}
Tcl_AppendToObj(varPtr[varIndex], string + length, size - length);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 12: /* appendself2 */
if (objc != 4) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varPtr, varIndex, Tcl_NewObj());
}
|
| ︙ | ︙ |
Changes to generic/tclThreadStorage.c.
| ︙ | ︙ | |||
44 45 46 47 48 49 50 |
} tsdGlobal = { NULL, 0, NULL };
/*
* The type of the data held per thread in a system TSD.
*/
typedef struct {
| | | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
} tsdGlobal = { NULL, 0, NULL };
/*
* The type of the data held per thread in a system TSD.
*/
typedef struct {
void **tablePtr; /* The table of Tcl TSDs. */
sig_atomic_t allocated; /* The size of the table in the current
* thread. */
} TSDTable;
/*
* The actual type of Tcl_ThreadDataKey.
*/
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 |
*/
void *
TclThreadStorageKeyGet(
Tcl_ThreadDataKey *dataKeyPtr)
{
TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetGlobalTSD(tsdGlobal.key);
| | | 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 |
*/
void *
TclThreadStorageKeyGet(
Tcl_ThreadDataKey *dataKeyPtr)
{
TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetGlobalTSD(tsdGlobal.key);
void *resultPtr = NULL;
TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr;
sig_atomic_t offset = keyPtr->offset;
if ((tsdTablePtr != NULL) && (offset > 0)
&& (offset < tsdTablePtr->allocated)) {
resultPtr = tsdTablePtr->tablePtr[offset];
}
|
| ︙ | ︙ |
Changes to generic/tclThreadTest.c.
| ︙ | ︙ | |||
873 874 875 876 877 878 879 |
/*
* Queue the event and poke the other thread's notifier.
*/
threadEventPtr->event.proc = ThreadEventProc;
Tcl_ThreadQueueEvent(threadId, (Tcl_Event *) threadEventPtr,
| | < | 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 |
/*
* Queue the event and poke the other thread's notifier.
*/
threadEventPtr->event.proc = ThreadEventProc;
Tcl_ThreadQueueEvent(threadId, (Tcl_Event *) threadEventPtr,
TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY);
if (!wait) {
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
/*
|
| ︙ | ︙ |
Changes to generic/tclTimer.c.
| ︙ | ︙ | |||
207 208 209 210 211 212 213 | * Removes the timer and idle event sources and remaining events. * *---------------------------------------------------------------------- */ static void TimerExitProc( | | | 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 |
* Removes the timer and idle event sources and remaining events.
*
*----------------------------------------------------------------------
*/
static void
TimerExitProc(
TCL_UNUSED(void *))
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL);
if (tsdPtr != NULL) {
TimerHandler *timerHandlerPtr;
|
| ︙ | ︙ | |||
394 395 396 397 398 399 400 | * May update the maximum notifier block time. * *---------------------------------------------------------------------- */ static void TimerSetupProc( | | | 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 |
* May update the maximum notifier block time.
*
*----------------------------------------------------------------------
*/
static void
TimerSetupProc(
TCL_UNUSED(void *),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
Tcl_Time blockTime;
ThreadSpecificData *tsdPtr = InitTimer();
if (((flags & TCL_IDLE_EVENTS) && tsdPtr->idleList)
|| ((flags & TCL_TIMER_EVENTS) && tsdPtr->timerPending)) {
|
| ︙ | ︙ | |||
452 453 454 455 456 457 458 | * May queue an event and update the maximum notifier block time. * *---------------------------------------------------------------------- */ static void TimerCheckProc( | | | 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 |
* May queue an event and update the maximum notifier block time.
*
*----------------------------------------------------------------------
*/
static void
TimerCheckProc(
TCL_UNUSED(void *),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
Tcl_Event *timerEvPtr;
Tcl_Time blockTime;
ThreadSpecificData *tsdPtr = InitTimer();
if ((flags & TCL_TIMER_EVENTS) && tsdPtr->firstTimerHandlerPtr) {
|
| ︙ | ︙ | |||
774 775 776 777 778 779 780 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_AfterObjCmd( | | | 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_AfterObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_WideInt ms = 0; /* Number of milliseconds to wait */
Tcl_Time wakeup;
AfterInfo *afterPtr;
|
| ︙ | ︙ |
Changes to generic/tclTrace.c.
| ︙ | ︙ | |||
124 125 126 127 128 129 130 | /* * Declarations for local functions to this file: */ static int CallTraceFunction(Tcl_Interp *interp, Trace *tracePtr, Command *cmdPtr, const char *command, size_t numChars, int objc, Tcl_Obj *const objv[]); | | | | | | | 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 158 159 |
/*
* Declarations for local functions to this file:
*/
static int CallTraceFunction(Tcl_Interp *interp, Trace *tracePtr,
Command *cmdPtr, const char *command, size_t numChars,
int objc, Tcl_Obj *const objv[]);
static char * TraceVarProc(void *clientData, Tcl_Interp *interp,
const char *name1, const char *name2, int flags);
static void TraceCommandProc(void *clientData,
Tcl_Interp *interp, const char *oldName,
const char *newName, int flags);
static Tcl_CmdObjTraceProc TraceExecutionProc;
static int StringTraceProc(void *clientData,
Tcl_Interp *interp, int level,
const char *command, Tcl_Command commandInfo,
int objc, Tcl_Obj *const objv[]);
static void StringTraceDeleteProc(void *clientData);
static void DisposeTraceResult(int flags, char *result);
static int TraceVarEx(Tcl_Interp *interp, const char *part1,
const char *part2, VarTrace *tracePtr);
/*
* The following structure holds the client data for string-based
* trace procs
*/
typedef struct {
void *clientData; /* Client data from Tcl_CreateTrace */
Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */
} StringTraceData;
/*
* Convenience macros for iterating over the list of traces. Note that each of
* these *must* be treated as a command, and *must* have a block following it.
*/
|
| ︙ | ︙ | |||
309 310 311 312 313 314 315 |
} else {
code = traceSubCmds[2](interp, TRACE_REMOVE, objc+1, copyObjv);
}
Tcl_DecrRefCount(opsList);
return code;
}
case TRACE_OLD_VINFO: {
| | | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 |
} else {
code = traceSubCmds[2](interp, TRACE_REMOVE, objc+1, copyObjv);
}
Tcl_DecrRefCount(opsList);
return code;
}
case TRACE_OLD_VINFO: {
void *clientData;
char ops[5];
Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
411 412 413 414 415 416 417 |
TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE,
TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP
} index;
switch (optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
| | | | | 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 |
TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE,
TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP
} index;
switch (optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
int flags = 0, result;
size_t i, listLen;
Tcl_Obj **elemPtrs;
if (objc != 6) {
Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
return TCL_ERROR;
}
/*
* Make sure the ops argument is a list object; get its length and a
* pointer to its array of element pointers.
*/
result = TclListObjGetElementsM(interp, objv[4], &listLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
if (listLen == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad operation list \"\": must be one or more of"
" enter, leave, enterstep, or leavestep", -1));
|
| ︙ | ︙ | |||
488 489 490 491 492 493 494 |
} else {
/*
* Search through all of our traces on this command to see if
* there's one with the given command. If so, then delete the
* first one that matches.
*/
| | | 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 |
} else {
/*
* Search through all of our traces on this command to see if
* there's one with the given command. If so, then delete the
* first one that matches.
*/
void *clientData;
/*
* First ensure the name given is valid.
*/
name = TclGetString(objv[3]);
if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) {
|
| ︙ | ︙ | |||
547 548 549 550 551 552 553 |
break;
}
}
}
break;
}
case TRACE_INFO: {
| | | | 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 |
break;
}
}
}
break;
}
case TRACE_INFO: {
void *clientData;
Tcl_Obj *resultListPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
name = TclGetString(objv[3]);
/*
* First ensure the name given is valid.
*/
if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
resultListPtr = Tcl_NewListObj(0, NULL);
FOREACH_COMMAND_TRACE(interp, name, clientData) {
size_t numOps = 0;
Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
/*
* Build a list with the ops list as the first obj element and the
* tcmdPtr->command string as the second obj element. Append this
* list (as an element) to the end of the result object list.
|
| ︙ | ︙ | |||
595 596 597 598 599 600 601 |
TclNewLiteralStringObj(opObj, "enterstep");
Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
}
if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) {
TclNewLiteralStringObj(opObj, "leavestep");
Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
}
| | | 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 |
TclNewLiteralStringObj(opObj, "enterstep");
Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
}
if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) {
TclNewLiteralStringObj(opObj, "leavestep");
Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
}
TclListObjLengthM(NULL, elemObjPtr, &numOps);
if (0 == numOps) {
Tcl_DecrRefCount(elemObjPtr);
continue;
}
eachTraceObjPtr = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
Tcl_DecrRefCount(elemObjPtr);
|
| ︙ | ︙ | |||
654 655 656 657 658 659 660 |
size_t commandLength, length;
static const char *const opStrings[] = { "delete", "rename", NULL };
enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME } index;
switch (optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
| | | | | 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 |
size_t commandLength, length;
static const char *const opStrings[] = { "delete", "rename", NULL };
enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME } index;
switch (optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
int flags = 0, result;
size_t i, listLen;
Tcl_Obj **elemPtrs;
if (objc != 6) {
Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
return TCL_ERROR;
}
/*
* Make sure the ops argument is a list object; get its length and a
* pointer to its array of element pointers.
*/
result = TclListObjGetElementsM(interp, objv[4], &listLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
if (listLen == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad operation list \"\": must be one or more of"
" delete or rename", -1));
|
| ︙ | ︙ | |||
723 724 725 726 727 728 729 |
} else {
/*
* Search through all of our traces on this command to see if
* there's one with the given command. If so, then delete the
* first one that matches.
*/
| | | 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 |
} else {
/*
* Search through all of our traces on this command to see if
* there's one with the given command. If so, then delete the
* first one that matches.
*/
void *clientData;
/*
* First ensure the name given is valid.
*/
name = TclGetString(objv[3]);
if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) {
|
| ︙ | ︙ | |||
753 754 755 756 757 758 759 |
break;
}
}
}
break;
}
case TRACE_INFO: {
| | | | | 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 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 |
break;
}
}
}
break;
}
case TRACE_INFO: {
void *clientData;
Tcl_Obj *resultListPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
/*
* First ensure the name given is valid.
*/
name = TclGetString(objv[3]);
if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
resultListPtr = Tcl_NewListObj(0, NULL);
FOREACH_COMMAND_TRACE(interp, name, clientData) {
size_t numOps = 0;
Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
/*
* Build a list with the ops list as the first obj element and the
* tcmdPtr->command string as the second obj element. Append this
* list (as an element) to the end of the result object list.
*/
elemObjPtr = Tcl_NewListObj(0, NULL);
Tcl_IncrRefCount(elemObjPtr);
if (tcmdPtr->flags & TCL_TRACE_RENAME) {
TclNewLiteralStringObj(opObj, "rename");
Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
}
if (tcmdPtr->flags & TCL_TRACE_DELETE) {
TclNewLiteralStringObj(opObj, "delete");
Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
}
TclListObjLengthM(NULL, elemObjPtr, &numOps);
if (0 == numOps) {
Tcl_DecrRefCount(elemObjPtr);
continue;
}
eachTraceObjPtr = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
Tcl_DecrRefCount(elemObjPtr);
|
| ︙ | ︙ | |||
844 845 846 847 848 849 850 |
Tcl_Interp *interp, /* Current interpreter. */
enum traceOptions optionIndex, /* Add, info or remove */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *name, *command;
size_t commandLength, length;
| | | | | | 844 845 846 847 848 849 850 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 |
Tcl_Interp *interp, /* Current interpreter. */
enum traceOptions optionIndex, /* Add, info or remove */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *name, *command;
size_t commandLength, length;
void *clientData;
static const char *const opStrings[] = {
"array", "read", "unset", "write", NULL
};
enum operations {
TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, TRACE_VAR_WRITE
} index;
switch (optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
int flags = 0, result;
size_t i, listLen;
Tcl_Obj **elemPtrs;
if (objc != 6) {
Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
return TCL_ERROR;
}
/*
* Make sure the ops argument is a list object; get its length and a
* pointer to its array of element pointers.
*/
result = TclListObjGetElementsM(interp, objv[4], &listLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
if (listLen == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad operation list \"\": must be one or more of"
" array, read, unset, or write", -1));
|
| ︙ | ︙ | |||
1041 1042 1043 1044 1045 1046 1047 |
ClientData
Tcl_CommandTraceInfo(
Tcl_Interp *interp, /* Interpreter containing command. */
const char *cmdName, /* Name of command. */
TCL_UNUSED(int) /*flags*/,
Tcl_CommandTraceProc *proc, /* Function assocated with trace. */
| | | 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 |
ClientData
Tcl_CommandTraceInfo(
Tcl_Interp *interp, /* Interpreter containing command. */
const char *cmdName, /* Name of command. */
TCL_UNUSED(int) /*flags*/,
Tcl_CommandTraceProc *proc, /* Function assocated with trace. */
void *prevClientData) /* If non-NULL, gives last value returned by
* this function, so this call will return the
* next trace after that one. If NULL, this
* call will return the first trace. */
{
Command *cmdPtr;
CommandTrace *tracePtr;
|
| ︙ | ︙ | |||
1109 1110 1111 1112 1113 1114 1115 |
* traced. */
const char *cmdName, /* Name of command. */
int flags, /* OR-ed collection of bits, including any of
* TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any
* of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc, /* Function to call when specified ops are
* invoked upon cmdName. */
| | | 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 |
* traced. */
const char *cmdName, /* Name of command. */
int flags, /* OR-ed collection of bits, including any of
* TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any
* of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc, /* Function to call when specified ops are
* invoked upon cmdName. */
void *clientData) /* Arbitrary argument to pass to proc. */
{
Command *cmdPtr;
CommandTrace *tracePtr;
cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL,
TCL_LEAVE_ERR_MSG);
if (cmdPtr == NULL) {
|
| ︙ | ︙ | |||
1173 1174 1175 1176 1177 1178 1179 |
Tcl_UntraceCommand(
Tcl_Interp *interp, /* Interpreter containing command. */
const char *cmdName, /* Name of command. */
int flags, /* OR-ed collection of bits, including any of
* TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any
* of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc, /* Function assocated with trace. */
| | | 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 |
Tcl_UntraceCommand(
Tcl_Interp *interp, /* Interpreter containing command. */
const char *cmdName, /* Name of command. */
int flags, /* OR-ed collection of bits, including any of
* TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any
* of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc, /* Function assocated with trace. */
void *clientData) /* Arbitrary argument to pass to proc. */
{
CommandTrace *tracePtr;
CommandTrace *prevPtr;
Command *cmdPtr;
Interp *iPtr = (Interp *)interp;
ActiveCommandTrace *activePtr;
int hasExecTraces = 0;
|
| ︙ | ︙ | |||
1278 1279 1280 1281 1282 1283 1284 | * Depends on the command associated with the trace. * *---------------------------------------------------------------------- */ static void TraceCommandProc( | | | 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 |
* Depends on the command associated with the trace.
*
*----------------------------------------------------------------------
*/
static void
TraceCommandProc(
void *clientData, /* Information about the command trace. */
Tcl_Interp *interp, /* Interpreter containing command. */
const char *oldName, /* Name of command being changed. */
const char *newName, /* New name of command. Empty string or NULL
* means command is being deleted (renamed to
* ""). */
int flags) /* OR-ed bits giving operation and other
* information. */
|
| ︙ | ︙ | |||
1718 1719 1720 1721 1722 1723 1724 | * May release memory. * *---------------------------------------------------------------------- */ static void CommandObjTraceDeleted( | | | 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 |
* May release memory.
*
*----------------------------------------------------------------------
*/
static void
CommandObjTraceDeleted(
void *clientData)
{
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
if (tcmdPtr->refCount-- <= 1) {
Tcl_Free(tcmdPtr);
}
}
|
| ︙ | ︙ | |||
1754 1755 1756 1757 1758 1759 1760 | * interpreter-wide trace. * *---------------------------------------------------------------------- */ static int TraceExecutionProc( | | | | 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 |
* interpreter-wide trace.
*
*----------------------------------------------------------------------
*/
static int
TraceExecutionProc(
void *clientData,
Tcl_Interp *interp,
int level,
const char *command,
TCL_UNUSED(Tcl_Command),
int objc,
Tcl_Obj *const objv[])
{
int call = 0;
Interp *iPtr = (Interp *) interp;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
int flags = tcmdPtr->curFlags;
int code = tcmdPtr->curCode;
int traceCode = TCL_OK;
|
| ︙ | ︙ | |||
1961 1962 1963 1964 1965 1966 1967 | * Depends on the command associated with the trace. * *---------------------------------------------------------------------- */ static char * TraceVarProc( | | | 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 |
* Depends on the command associated with the trace.
*
*----------------------------------------------------------------------
*/
static char *
TraceVarProc(
void *clientData, /* Information about the variable trace. */
Tcl_Interp *interp, /* Interpreter containing variable. */
const char *name1, /* Name of variable or array. */
const char *name2, /* Name of element within array; NULL means
* scalar variable is being referenced. */
int flags) /* OR-ed bits giving operation and other
* information. */
{
|
| ︙ | ︙ | |||
2100 2101 2102 2103 2104 2105 2106 | * nesting depth of command interpretation within the interpreter. The * 'command' argument is the ASCII text of the command being evaluated - * before any substitutions are performed. The 'commandInfo' argument * gives a handle to the command procedure that will be evaluated. The * 'objc' and 'objv' parameters give the parameter vector that will be * passed to the command procedure. Proc does not return a value. * | < < < < | 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 | * nesting depth of command interpretation within the interpreter. The * 'command' argument is the ASCII text of the command being evaluated - * before any substitutions are performed. The 'commandInfo' argument * gives a handle to the command procedure that will be evaluated. The * 'objc' and 'objv' parameters give the parameter vector that will be * passed to the command procedure. Proc does not return a value. * * The 'level' argument specifies the maximum nesting level of calls to * be traced. If the execution depth of the interpreter exceeds 'level', * the trace callback is not executed. * * The 'flags' argument is either zero or the value, * TCL_ALLOW_INLINE_COMPILATION. If the TCL_ALLOW_INLINE_COMPILATION flag * is not present, the bytecode compiler will not generate inline code |
| ︙ | ︙ | |||
2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 |
* applications such as profiling of run time.
*
* When the trace is deleted, the 'delProc' function will be invoked,
* passing it the original client data.
*
*----------------------------------------------------------------------
*/
Tcl_Trace
Tcl_CreateObjTrace(
Tcl_Interp *interp, /* Tcl interpreter */
int level, /* Maximum nesting level */
int flags, /* Flags, see above */
Tcl_CmdObjTraceProc *proc, /* Trace callback */
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 |
* applications such as profiling of run time.
*
* When the trace is deleted, the 'delProc' function will be invoked,
* passing it the original client data.
*
*----------------------------------------------------------------------
*/
typedef struct {
Tcl_CmdObjTraceProc2 *proc;
Tcl_CmdObjTraceDeleteProc *delProc;
void *clientData;
} TraceWrapperInfo;
static int traceWrapperProc(
void *clientData,
Tcl_Interp *interp,
int level,
const char *command,
Tcl_Command commandInfo,
int objc,
Tcl_Obj *const objv[])
{
TraceWrapperInfo *info = (TraceWrapperInfo *)clientData;
return info->proc(info->clientData, interp, level, command, commandInfo, objc, objv);
}
static void traceWrapperDelProc(void *clientData)
{
TraceWrapperInfo *info = (TraceWrapperInfo *)clientData;
clientData = info->clientData;
if (info->delProc) {
info->delProc(clientData);
}
Tcl_Free(info);
}
Tcl_Trace
Tcl_CreateObjTrace2(
Tcl_Interp *interp, /* Tcl interpreter */
int level, /* Maximum nesting level */
int flags, /* Flags, see above */
Tcl_CmdObjTraceProc2 *proc, /* Trace callback */
void *clientData, /* Client data for the callback */
Tcl_CmdObjTraceDeleteProc *delProc)
/* Function to call when trace is deleted */
{
TraceWrapperInfo *info = (TraceWrapperInfo *)Tcl_Alloc(sizeof(TraceWrapperInfo));
info->proc = proc;
info->delProc = delProc;
info->clientData = clientData;
return Tcl_CreateObjTrace(interp, level, flags,
(proc ? traceWrapperProc : NULL),
info, traceWrapperDelProc);
}
Tcl_Trace
Tcl_CreateObjTrace(
Tcl_Interp *interp, /* Tcl interpreter */
int level, /* Maximum nesting level */
int flags, /* Flags, see above */
Tcl_CmdObjTraceProc *proc, /* Trace callback */
void *clientData, /* Client data for the callback */
Tcl_CmdObjTraceDeleteProc *delProc)
/* Function to call when trace is deleted */
{
Trace *tracePtr;
Interp *iPtr = (Interp *) interp;
/*
|
| ︙ | ︙ | |||
2192 2193 2194 2195 2196 2197 2198 | * From now on, proc will be called just before a command procedure is * called to execute a Tcl command. Calls to proc will have the following * form: * * void * proc(clientData, interp, level, command, cmdProc, cmdClientData, * argc, argv) | | | | 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 |
* From now on, proc will be called just before a command procedure is
* called to execute a Tcl command. Calls to proc will have the following
* form:
*
* void
* proc(clientData, interp, level, command, cmdProc, cmdClientData,
* argc, argv)
* void *clientData;
* Tcl_Interp *interp;
* int level;
* char *command;
* int (*cmdProc)();
* void *cmdClientData;
* int argc;
* char **argv;
* {
* }
*
* The clientData and interp arguments to proc will be the same as the
* corresponding arguments to this function. Level gives the nesting
|
| ︙ | ︙ | |||
2222 2223 2224 2225 2226 2227 2228 |
Tcl_Trace
Tcl_CreateTrace(
Tcl_Interp *interp, /* Interpreter in which to create trace. */
int level, /* Only call proc for commands at nesting
* level<=argument level (1=>top level). */
Tcl_CmdTraceProc *proc, /* Function to call before executing each
* command. */
| | | 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 |
Tcl_Trace
Tcl_CreateTrace(
Tcl_Interp *interp, /* Interpreter in which to create trace. */
int level, /* Only call proc for commands at nesting
* level<=argument level (1=>top level). */
Tcl_CmdTraceProc *proc, /* Function to call before executing each
* command. */
void *clientData) /* Arbitrary value word to pass to proc. */
{
StringTraceData *data = (StringTraceData *)Tcl_Alloc(sizeof(StringTraceData));
data->clientData = clientData;
data->proc = proc;
return Tcl_CreateObjTrace(interp, level, 0, StringTraceProc,
data, StringTraceDeleteProc);
|
| ︙ | ︙ | |||
2250 2251 2252 2253 2254 2255 2256 | * Whatever the string-based trace function does. * *---------------------------------------------------------------------- */ static int StringTraceProc( | | | 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 |
* Whatever the string-based trace function does.
*
*----------------------------------------------------------------------
*/
static int
StringTraceProc(
void *clientData,
Tcl_Interp *interp,
int level,
const char *command,
Tcl_Command commandInfo,
int objc,
Tcl_Obj *const *objv)
{
|
| ︙ | ︙ | |||
2306 2307 2308 2309 2310 2311 2312 | * Allocated memory is returned to the system. * *---------------------------------------------------------------------- */ static void StringTraceDeleteProc( | | | 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 |
* Allocated memory is returned to the system.
*
*----------------------------------------------------------------------
*/
static void
StringTraceDeleteProc(
void *clientData)
{
Tcl_Free(clientData);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2855 2856 2857 2858 2859 2860 2861 |
* trace applies to scalar variable or array
* as-a-whole. */
int flags, /* OR-ed collection of bits describing current
* trace, including any of TCL_TRACE_READS,
* TCL_TRACE_WRITES, TCL_TRACE_UNSETS,
* TCL_GLOBAL_ONLY, and TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc, /* Function assocated with trace. */
| | | 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 |
* trace applies to scalar variable or array
* as-a-whole. */
int flags, /* OR-ed collection of bits describing current
* trace, including any of TCL_TRACE_READS,
* TCL_TRACE_WRITES, TCL_TRACE_UNSETS,
* TCL_GLOBAL_ONLY, and TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc, /* Function assocated with trace. */
void *clientData) /* Arbitrary argument to pass to proc. */
{
VarTrace *tracePtr;
VarTrace *prevPtr, *nextPtr;
Var *varPtr, *arrayPtr;
Interp *iPtr = (Interp *) interp;
ActiveVarTrace *activePtr;
int flagMask, allFlags = 0;
|
| ︙ | ︙ | |||
2983 2984 2985 2986 2987 2988 2989 |
const char *part1, /* Name of variable or array. */
const char *part2, /* Name of element within array; NULL means
* trace applies to scalar variable or array
* as-a-whole. */
int flags, /* OR-ed combination of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc, /* Function assocated with trace. */
| | | 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 |
const char *part1, /* Name of variable or array. */
const char *part2, /* Name of element within array; NULL means
* trace applies to scalar variable or array
* as-a-whole. */
int flags, /* OR-ed combination of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc, /* Function assocated with trace. */
void *prevClientData) /* If non-NULL, gives last value returned by
* this function, so this call will return the
* next trace after that one. If NULL, this
* call will return the first trace. */
{
Interp *iPtr = (Interp *) interp;
Var *varPtr, *arrayPtr;
Tcl_HashEntry *hPtr;
|
| ︙ | ︙ | |||
3061 3062 3063 3064 3065 3066 3067 |
* as-a-whole. */
int flags, /* OR-ed collection of bits, including any of
* TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and
* TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc, /* Function to call when specified ops are
* invoked upon varName. */
| | | 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 |
* as-a-whole. */
int flags, /* OR-ed collection of bits, including any of
* TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and
* TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc, /* Function to call when specified ops are
* invoked upon varName. */
void *clientData) /* Arbitrary argument to pass to proc. */
{
VarTrace *tracePtr;
int result;
tracePtr = (VarTrace *)Tcl_Alloc(sizeof(VarTrace));
tracePtr->traceProc = proc;
tracePtr->clientData = clientData;
|
| ︙ | ︙ |
Changes to generic/tclUniData.c.
| ︙ | ︙ | |||
203 204 205 206 207 208 209 |
11456, 1344, 11488, 11520, 11552, 3296, 3296, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 7776, 4704, 11584, 11616, 11648, 3296,
3296, 11680, 11712, 11744, 11776, 4736, 11808, 3296, 11840, 11872,
11904, 3296, 3296, 1344, 11936, 11968, 6880, 12000, 12032, 12064, 12096,
12128, 3296, 12160, 12192, 1344, 12224, 12256, 12288, 12320, 12352,
3296, 3296, 1344, 1344, 12384, 3296, 12416, 12448, 12480, 12512, 1344,
12544, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 12576,
| | | | | | | | | | | | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > | > | > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > < < < < < < < < < < < < < < < < < < < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | < | < < < < | < | > > > > | < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 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 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 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 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 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 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 |
11456, 1344, 11488, 11520, 11552, 3296, 3296, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 7776, 4704, 11584, 11616, 11648, 3296,
3296, 11680, 11712, 11744, 11776, 4736, 11808, 3296, 11840, 11872,
11904, 3296, 3296, 1344, 11936, 11968, 6880, 12000, 12032, 12064, 12096,
12128, 3296, 12160, 12192, 1344, 12224, 12256, 12288, 12320, 12352,
3296, 3296, 1344, 1344, 12384, 3296, 12416, 12448, 12480, 12512, 1344,
12544, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 12576,
1344, 12608, 3296, 12640, 12128, 12672, 12704, 12736, 12768, 12736,
12800, 7776, 12832, 12864, 12896, 12928, 5280, 12960, 12992, 13024,
13056, 13088, 13120, 13152, 5280, 13184, 13216, 13248, 13280, 13312,
13344, 3296, 13376, 13408, 13440, 13472, 13504, 13536, 13568, 13600,
3296, 3296, 3296, 3296, 1344, 13632, 13664, 13696, 1344, 13728, 13760,
3296, 3296, 3296, 3296, 3296, 1344, 13792, 13824, 3296, 1344, 13856,
13888, 13920, 1344, 13952, 13984, 3296, 4032, 14016, 14048, 3296, 3296,
3296, 3296, 3296, 1344, 14080, 3296, 3296, 3296, 14112, 14144, 14176,
14208, 14240, 14272, 3296, 3296, 14304, 14336, 14368, 14400, 14432,
14464, 1344, 14496, 14528, 1344, 4608, 14560, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 14592, 14624, 14656, 14688, 14720, 14752, 3296, 3296,
14784, 14816, 14848, 14880, 14912, 13984, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 14944, 14976, 15008, 15040, 3296, 3296, 15072,
15104, 15136, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 9920, 3296, 3296, 3296, 10816,
10816, 10816, 15168, 1344, 1344, 1344, 1344, 1344, 1344, 15200, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 12736, 1344, 1344,
15232, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 15264,
15296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 14048, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 4608, 4736, 15328, 1344, 4736, 15360, 15392, 1344, 15424, 15456,
15488, 15520, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
14112, 14144, 15552, 3296, 3296, 3296, 1344, 1344, 15584, 15616, 15648,
3296, 3296, 15680, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 15712, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 4704, 3296, 12384, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 15744, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
15776, 15808, 15840, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 9792, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 1344, 1344, 1344, 15872, 15904, 15936, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 704, 15968, 16000, 4928, 4928, 4928, 16032, 3296, 4928, 4928,
4928, 4928, 4928, 4928, 4928, 8000, 4928, 16064, 4928, 16096, 16128,
16160, 4928, 6848, 4928, 4928, 16192, 3296, 3296, 3296, 16224, 16224,
4928, 4928, 16256, 16288, 3296, 3296, 3296, 3296, 16320, 16352, 16384,
16416, 16448, 16480, 16512, 16544, 16576, 16608, 16640, 16672, 16704,
16320, 16352, 16736, 16416, 16768, 16800, 16832, 16544, 16864, 16896,
16928, 16960, 16992, 17024, 17056, 17088, 17120, 17152, 17184, 4928,
4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928,
4928, 4928, 4928, 704, 17216, 704, 17248, 17280, 17312, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 17344, 17376, 3296,
3296, 3296, 3296, 3296, 3296, 17408, 17440, 5664, 17472, 17504, 3296,
3296, 3296, 1344, 17536, 17568, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 12736, 17600, 1344, 17632, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 12736,
17664, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 17696, 1344, 1344, 1344, 1344, 1344, 1344, 17728, 3296, 17760,
17792, 17824, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 17856, 6880, 17888, 3296, 3296, 17920, 17952, 3296,
3296, 3296, 3296, 3296, 3296, 17984, 18016, 18048, 18080, 18112, 18144,
3296, 18176, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 4928,
18208, 4928, 4928, 7968, 18240, 18272, 8000, 18304, 4928, 4928, 4928,
4928, 18336, 3296, 18368, 18400, 18432, 18464, 18496, 3296, 3296, 3296,
3296, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 18528, 4928, 4928,
4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928,
4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 18560, 18592, 4928,
4928, 4928, 18624, 4928, 4928, 18656, 18688, 18208, 4928, 18720, 4928,
18752, 18784, 3296, 3296, 4928, 4928, 4928, 4928, 4928, 4928, 4928,
4928, 4928, 4928, 7968, 18816, 18848, 18880, 18912, 18944, 4928, 4928,
4928, 4928, 18976, 4928, 6848, 19008, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 3296, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 9920, 1344, 1344, 1344, 1344, 1344, 1344, 11328,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
19040, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 19072, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 11328, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296,
3296, 3296, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1792, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 15520
#endif /* TCL_UTF_MAX > 3 */
};
/*
* The groupMap is indexed by combining the alternate page number with
* the page offset and returns a group number that identifies a unique
* set of character attributes.
|
| ︙ | ︙ | |||
728 729 730 731 732 733 734 |
9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 3, 18, 18, 18, 18,
18, 18, 18, 14, 15, 93, 125, 125, 3, 15, 15, 15, 15, 15, 15, 15, 15,
0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 0, 93, 15, 125, 93, 125,
125, 125, 125, 125, 0, 93, 125, 125, 0, 125, 125, 93, 93, 0, 0, 0,
0, 0, 0, 0, 125, 125, 0, 0, 0, 0, 0, 0, 15, 15, 0, 15, 15, 93, 93,
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 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 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 |
9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 3, 18, 18, 18, 18,
18, 18, 18, 14, 15, 93, 125, 125, 3, 15, 15, 15, 15, 15, 15, 15, 15,
0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 0, 93, 15, 125, 93, 125,
125, 125, 125, 125, 0, 93, 125, 125, 0, 125, 125, 93, 93, 0, 0, 0,
0, 0, 0, 0, 125, 125, 0, 0, 0, 0, 0, 0, 15, 15, 0, 15, 15, 93, 93,
0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 15, 15, 125, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 93, 93, 125, 125, 15, 15, 15, 15, 15, 15, 15,
15, 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 15, 125,
125, 125, 93, 93, 93, 93, 0, 125, 125, 125, 0, 125, 125, 125, 93, 15,
14, 0, 0, 0, 0, 15, 15, 15, 125, 18, 18, 18, 18, 18, 18, 18, 15, 15,
15, 93, 93, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 18, 18,
18, 18, 18, 18, 14, 15, 15, 15, 15, 15, 15, 0, 93, 125, 125, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 0, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 93, 0, 0,
0, 0, 125, 125, 125, 93, 93, 93, 0, 93, 0, 125, 125, 125, 125, 125,
125, 125, 125, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0,
125, 125, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 15, 15, 93, 93, 93, 93, 93,
93, 93, 0, 0, 0, 0, 4, 15, 15, 15, 15, 15, 15, 92, 93, 93, 93, 93,
93, 93, 93, 93, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 0, 15, 0, 15, 15, 15, 15, 15,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 93, 15, 15, 93, 93, 93, 93, 93, 93, 93, 93, 93, 15, 0,
0, 15, 15, 15, 15, 15, 0, 92, 0, 93, 93, 93, 93, 93, 93, 93, 0, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 15, 15, 15, 15, 15, 14, 14, 14, 3,
3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 14, 3, 14, 14, 14, 93, 93,
14, 14, 14, 14, 14, 14, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 14, 93, 14, 93, 14, 93, 5, 6, 5, 6, 125, 125,
15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 125, 93, 93, 93, 93, 93,
3, 93, 93, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 0, 14, 14, 14, 14, 14, 14, 14, 14, 93, 14, 14,
14, 14, 14, 14, 0, 14, 14, 3, 3, 3, 3, 3, 14, 14, 14, 14, 3, 3, 0,
0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 93,
93, 93, 93, 125, 93, 93, 93, 93, 93, 93, 125, 93, 93, 125, 125, 93,
93, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 3, 3, 15, 15, 15,
15, 15, 15, 125, 125, 93, 93, 15, 15, 15, 15, 93, 93, 93, 15, 125,
125, 125, 15, 15, 125, 125, 125, 125, 125, 125, 125, 15, 15, 15, 93,
93, 93, 93, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93,
125, 125, 93, 93, 125, 125, 125, 125, 125, 125, 93, 15, 125, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 125, 125, 125, 93, 14, 14, 126, 126, 126, 126,
126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126,
126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126,
126, 126, 126, 126, 126, 126, 0, 126, 0, 0, 0, 0, 0, 126, 0, 0, 127,
127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127,
127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127,
127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127,
3, 92, 127, 127, 127, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15,
15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 0, 15, 15, 15, 15,
0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 0,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0,
15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 0, 15, 15,
15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
0, 0, 93, 93, 93, 3, 3, 3, 3, 3, 3, 3, 3, 3, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 128, 128, 128, 128,
128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128,
128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128,
128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128,
128, 128, 105, 105, 105, 105, 105, 105, 0, 0, 111, 111, 111, 111, 111,
111, 0, 0, 8, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 14, 3, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 2, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 5, 6, 0, 0, 0, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 3, 3, 3, 129, 129, 129, 15, 15, 15, 15, 15,
15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 125, 0, 0, 0, 0, 0,
0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 93, 93, 125, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 0, 93, 93, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 125, 93, 93, 93, 93, 93, 93,
93, 125, 125, 125, 125, 125, 125, 125, 125, 93, 125, 125, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 3, 3, 3, 92, 3, 3, 3, 4, 15, 93, 0,
0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 8, 3, 3,
3, 3, 93, 93, 93, 17, 93, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0,
0, 0, 15, 15, 15, 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15,
93, 93, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 93, 15, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
|
| ︙ | ︙ | |||
1280 1281 1282 1283 1284 1285 1286 |
103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103,
103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 0, 0, 0,
0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 15, 15, 15, 15, 93, 93, 93, 93,
0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0,
0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 93, 93, 8, 0, 0, 15, 15, 0,
| | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | 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 1351 1352 1353 1354 1355 1356 1357 |
103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103,
103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 0, 0, 0,
0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 15, 15, 15, 15, 93, 93, 93, 93,
0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0,
0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 93, 93, 8, 0, 0, 15, 15, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 93, 93,
18, 18, 18, 18, 18, 18, 18, 15, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 18, 18, 18, 18,
3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 93, 93, 93, 93, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 18, 18,
18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 125, 93, 125, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 93, 15, 15, 93, 93, 15, 0, 0, 0, 0, 0,
0, 0, 0, 0, 93, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 125, 125, 125, 93, 93, 93, 93, 125, 125, 93, 93, 3, 3,
17, 3, 3, 3, 3, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 0, 0, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 0, 0, 0, 0, 0, 0, 93, 93, 93, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 125,
93, 93, 93, 93, 93, 93, 93, 93, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3,
3, 3, 3, 15, 125, 125, 15, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 3, 3, 15,
0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 125, 93, 93, 93, 93,
93, 93, 93, 93, 93, 125, 125, 15, 15, 15, 15, 3, 3, 3, 3, 93, 93, 93,
93, 3, 125, 93, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 3, 15, 3, 3, 3, 0,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 125, 125, 125, 93, 93, 93, 125, 125, 93, 125, 93, 93,
3, 3, 3, 3, 3, 3, 93, 15, 15, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15,
15, 15, 15, 15, 0, 15, 0, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 3, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 93, 125, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93,
0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 93,
93, 125, 125, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 0, 0,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15,
15, 15, 15, 15, 0, 93, 93, 15, 125, 125, 93, 125, 125, 125, 125, 0,
0, 125, 125, 0, 0, 125, 125, 125, 0, 0, 15, 0, 0, 0, 0, 0, 0, 125,
0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 125, 125, 0, 0, 93, 93, 93, 93,
93, 93, 93, 0, 0, 0, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 125, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93,
125, 125, 93, 93, 93, 125, 93, 15, 15, 15, 15, 3, 3, 3, 3, 3, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 0, 3, 93, 15, 15, 15, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
| ︙ | ︙ | |||
1380 1381 1382 1383 1384 1385 1386 |
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93,
93, 93, 93, 125, 15, 93, 93, 93, 93, 3, 3, 3, 3, 3, 3, 3, 3, 93, 0,
0, 0, 0, 0, 0, 0, 0, 15, 93, 93, 93, 93, 93, 93, 125, 125, 93, 93,
93, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 125, 93, 93, 3, 3, 3, 15,
3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15,
| | > | | | | | | | | | | | | | | | | | | > > > > > | | | > | | | | | | | | | | | | > | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | > > | | < < | | | | | | | | | | | | | | | | > > > | > > > | | | | > | > > | > > > | > | | | > | | > > > > > < < < < < < < < < < < < | | | | | < < < < < < < | | | | | | | | | | | | | | | > | | | > > | > | | | | | > > | | | 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 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 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 |
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93,
93, 93, 93, 125, 15, 93, 93, 93, 93, 3, 3, 3, 3, 3, 3, 3, 3, 93, 0,
0, 0, 0, 0, 0, 0, 0, 15, 93, 93, 93, 93, 93, 93, 125, 125, 93, 93,
93, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 125, 93, 93, 3, 3, 3, 15,
3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 3, 3, 3, 3, 3, 3, 3,
3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 93, 93,
93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93, 93, 125, 93, 15, 3, 3, 3,
3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 0, 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 0, 125, 93, 93, 93, 93, 93, 93, 93, 125,
93, 93, 125, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15,
15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 93, 0, 0, 0,
93, 0, 93, 93, 0, 93, 93, 93, 93, 93, 93, 93, 15, 93, 0, 0, 0, 0, 0,
0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15,
15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 125, 125, 125, 125, 125, 0, 93, 93, 0, 125, 125, 93,
125, 93, 15, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 125, 125, 3, 3, 0,
0, 0, 0, 0, 0, 0, 93, 93, 15, 125, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 125, 125, 93, 93, 93, 93, 93, 0, 0, 0, 125,
125, 93, 125, 93, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 9, 9, 9, 9,
9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 4, 4, 4, 4, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 129, 129, 129, 129, 129, 129, 129, 129,
129, 129, 129, 129, 129, 129, 129, 0, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 3, 3, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
17, 17, 17, 17, 17, 93, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 3, 3, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 0, 0, 93, 93, 93, 93, 93, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
93, 93, 93, 93, 93, 93, 93, 3, 3, 3, 3, 3, 14, 14, 14, 14, 92, 92,
92, 92, 3, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 0, 18, 18, 18, 18, 18, 18, 18, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 3, 3, 3, 3, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 0, 0, 0, 93, 15, 125, 125, 125, 125, 125, 125,
125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125,
125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125,
125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125,
125, 125, 125, 125, 125, 125, 125, 0, 0, 0, 0, 0, 0, 0, 93, 93, 93,
93, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 3,
92, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 125, 125, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 92, 92,
92, 0, 92, 92, 92, 92, 92, 92, 92, 0, 92, 92, 0, 15, 15, 15, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15,
15, 15, 0, 0, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15,
15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 14, 93, 93, 3, 17,
17, 17, 17, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0,
0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 125, 125, 93, 93, 93, 14,
14, 14, 125, 125, 125, 125, 125, 125, 17, 17, 17, 17, 17, 17, 17, 17,
93, 93, 93, 93, 93, 93, 93, 93, 14, 14, 93, 93, 93, 93, 93, 93, 93,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 93, 93, 93, 93,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 93, 93, 93, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 21, 21, 21, 21, 21, 21, 21, 0, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108,
0, 108, 108, 0, 0, 108, 0, 0, 108, 108, 0, 0, 108, 108, 108, 108, 0,
108, 108, 108, 108, 108, 108, 108, 108, 21, 21, 21, 21, 0, 21, 0, 21,
21, 21, 21, 21, 21, 21, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 108, 108, 0, 108, 108, 108, 108, 0,
0, 108, 108, 108, 108, 108, 108, 108, 108, 0, 108, 108, 108, 108, 108,
108, 108, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108, 108, 0, 108, 108,
108, 108, 0, 108, 108, 108, 108, 108, 0, 108, 0, 0, 0, 108, 108, 108,
108, 108, 108, 108, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 108, 108, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 21, 21, 21, 21, 21, 21, 0, 0, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 7, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7,
21, 21, 21, 21, 21, 21, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21,
21, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 7, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 7, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 7, 21, 21, 21, 21, 21, 21, 108, 21, 0, 0, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 14, 14, 14, 14, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 14, 14, 14, 14, 14, 14, 14,
14, 93, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 93,
14, 14, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 15, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 0, 0, 0, 0, 0,
0, 21, 21, 21, 21, 21, 21, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 0, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 0, 93, 93, 93,
93, 93, 93, 93, 0, 93, 93, 0, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 92,
92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92,
92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 93, 93, 93, 93,
93, 93, 93, 92, 92, 92, 92, 92, 92, 92, 0, 0, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 0, 0, 0, 0, 15, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 0, 0, 0, 0, 0, 4, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 92, 93, 93, 93, 93, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0,
0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 15, 15, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15,
15, 15, 15, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 93, 93, 93, 93,
93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 206, 206, 206, 206, 206, 206,
206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206,
206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206,
207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
|
| ︙ | ︙ | |||
1591 1592 1593 1594 1595 1596 1597 |
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0,
0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 14,
14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 11, 11, 11, 11, 11,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
| | | > > | | | | | | | | | | | | | | | | | | | | | < | 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 |
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0,
0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 14,
14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 11, 11, 11, 11, 11,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0,
0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0,
0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0,
0, 0, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14,
14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 0,
0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 0, 0, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 14, 14, 14, 14, 14, 14,
14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0,
14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14,
14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15,
15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
#endif /* TCL_UTF_MAX > 3 */
};
/*
* Each group represents a unique set of character attributes. The attributes
* are encoded into a 32-bit value as follows:
*
|
| ︙ | ︙ | |||
1668 1669 1670 1671 1672 1673 1674 |
-2760383, -2760127, -2768575, 1859714, -9044927, -10823615, -12158,
-10830783, -10833599, -10832575, -10830015, -10817983, -10824127,
-10818751, 237633, -12223, -10830527, -9058239, 237698, 9949314,
18, 17, 10305, 10370, 10049, 10114, 8769, 8834
};
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
| | | 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 |
-2760383, -2760127, -2768575, 1859714, -9044927, -10823615, -12158,
-10830783, -10833599, -10832575, -10830015, -10817983, -10824127,
-10818751, 237633, -12223, -10830527, -9058239, 237698, 9949314,
18, 17, 10305, 10370, 10049, 10114, 8769, 8834
};
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1FFFFF) >= 0x323C0)
#else
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1F0000) != 0)
#endif
/*
* The following constants are used to determine the category of a
* Unicode character.
|
| ︙ | ︙ |
Changes to generic/tclUtf.c.
| ︙ | ︙ | |||
204 205 206 207 208 209 210 211 212 213 |
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
Tcl_UniCharToUtf(
int ch, /* The Tcl_UniChar to be stored in the
| > | > > > > > > > > > > > | | 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 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 |
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
#undef Tcl_UniCharToUtf
int
Tcl_UniCharToUtf(
int ch, /* The Tcl_UniChar to be stored in the
* buffer. Can be or'ed with flag TCL_COMBINE */
char *buf) /* Buffer in which the UTF-8 representation of
* the Tcl_UniChar is stored. Buffer must be
* large enough to hold the UTF-8 character
* (at most 4 bytes). */
{
#if TCL_UTF_MAX > 3
int flags = ch;
#endif
if (ch >= TCL_COMBINE) {
ch &= (TCL_COMBINE - 1);
}
if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) {
buf[0] = (char) ch;
return 1;
}
if (ch >= 0) {
if (ch <= 0x7FF) {
buf[1] = (char) ((ch | 0x80) & 0xBF);
buf[0] = (char) ((ch >> 6) | 0xC0);
return 2;
}
if (ch <= 0xFFFF) {
if (
#if TCL_UTF_MAX > 3
(flags & TCL_COMBINE) &&
#endif
((ch & 0xF800) == 0xD800)) {
if (ch & 0x0400) {
/* Low surrogate */
if (((buf[0] & 0xC0) == 0x80) && ((buf[1] & 0xCF) == 0)) {
/* Previous Tcl_UniChar was a high surrogate, so combine */
buf[2] = (char) ((ch & 0x3F) | 0x80);
buf[1] |= (char) (((ch >> 6) & 0x0F) | 0x80);
return 3;
|
| ︙ | ︙ | |||
373 374 375 376 377 378 379 |
p = string;
wEnd = uniStr + uniLength;
for (w = uniStr; w < wEnd; ) {
if (!len && ((*w & 0xFC00) != 0xDC00)) {
/* Special case for handling high surrogates. */
p += Tcl_UniCharToUtf(-1, p);
}
| | | 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 |
p = string;
wEnd = uniStr + uniLength;
for (w = uniStr; w < wEnd; ) {
if (!len && ((*w & 0xFC00) != 0xDC00)) {
/* Special case for handling high surrogates. */
p += Tcl_UniCharToUtf(-1, p);
}
len = Tcl_UniCharToUtf(*w | TCL_COMBINE, p);
p += len;
if ((*w >= 0xD800) && (len < 3)) {
len = 0; /* Indication that high surrogate was found */
}
w++;
}
if (!len) {
|
| ︙ | ︙ | |||
492 493 494 495 496 497 498 | } } /* * A three-byte-character lead-byte not followed by two trail-bytes * represents itself. */ | < | | 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 |
}
}
/*
* A three-byte-character lead-byte not followed by two trail-bytes
* represents itself.
*/
} else if (byte < 0xF5) {
if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) {
/*
* Four-byte-character lead byte followed by three trail bytes.
*/
*chPtr = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12)
| ((src[2] & 0x3F) << 6) | (src[3] & 0x3F));
if ((unsigned)(*chPtr - 0x10000) <= 0xFFFFF) {
|
| ︙ | ︙ | |||
588 589 590 591 592 593 594 | } } /* * A three-byte-character lead-byte not followed by two trail-bytes * represents itself. */ | < | | 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 |
}
}
/*
* A three-byte-character lead-byte not followed by two trail-bytes
* represents itself.
*/
} else if (byte < 0xF5) {
if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)) {
/*
* Four-byte-character lead byte followed by at least two trail bytes.
* We don't test the validity of 3th trail byte, see [ed29806ba]
*/
Tcl_UniChar high = (((byte & 0x07) << 8) | ((src[1] & 0x3F) << 2)
| ((src[2] & 0x3F) >> 4)) - 0x40;
|
| ︙ | ︙ | |||
1344 1345 1346 1347 1348 1349 1350 | /* * To keep badly formed Utf strings from getting inflated by the * conversion (thereby causing a segfault), only copy the upper case * char to dst if its size is <= the original char. */ | | | 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 |
/*
* To keep badly formed Utf strings from getting inflated by the
* conversion (thereby causing a segfault), only copy the upper case
* char to dst if its size is <= the original char.
*/
if (len < TclUtfCount(upChar)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(upChar, dst);
}
src += len;
}
|
| ︙ | ︙ | |||
1397 1398 1399 1400 1401 1402 1403 | /* * To keep badly formed Utf strings from getting inflated by the * conversion (thereby causing a segfault), only copy the lower case * char to dst if its size is <= the original char. */ | | | 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 |
/*
* To keep badly formed Utf strings from getting inflated by the
* conversion (thereby causing a segfault), only copy the lower case
* char to dst if its size is <= the original char.
*/
if (len < TclUtfCount(lowChar)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(lowChar, dst);
}
src += len;
}
|
| ︙ | ︙ | |||
1447 1448 1449 1450 1451 1452 1453 |
src = dst = str;
if (*src) {
len = TclUtfToUCS4(src, &ch);
titleChar = Tcl_UniCharToTitle(ch);
| | | | 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 |
src = dst = str;
if (*src) {
len = TclUtfToUCS4(src, &ch);
titleChar = Tcl_UniCharToTitle(ch);
if (len < TclUtfCount(titleChar)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(titleChar, dst);
}
src += len;
}
while (*src) {
len = TclUtfToUCS4(src, &ch);
lowChar = ch;
/* Special exception for Georgian Asomtavruli chars, no titlecase. */
if ((unsigned)(lowChar - 0x1C90) >= 0x30) {
lowChar = Tcl_UniCharToLower(lowChar);
}
if (len < TclUtfCount(lowChar)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(lowChar, dst);
}
src += len;
}
|
| ︙ | ︙ |
Changes to generic/tclUtil.c.
| ︙ | ︙ | |||
95 96 97 98 99 100 101 | #define CONVERT_ANY 16 /* * Prototypes for functions defined later in this file. */ static void ClearHash(Tcl_HashTable *tablePtr); | | | | | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 | #define CONVERT_ANY 16 /* * Prototypes for functions defined later in this file. */ static void ClearHash(Tcl_HashTable *tablePtr); static void FreeProcessGlobalValue(void *clientData); static void FreeThreadHash(void *clientData); static int GetEndOffsetFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, size_t endValue, Tcl_WideInt *indexPtr); static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr); static int GetWideForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, size_t endValue, Tcl_WideInt *widePtr); static int FindElement(Tcl_Interp *interp, const char *string, size_t stringLength, const char *typeStr, const char *typeCode, const char **elementPtr, const char **nextPtr, size_t *sizePtr, int *literalPtr); /* * The following is the Tcl object type definition for an object that * represents a list index in the form, "end-offset". It is used as a * performance optimization in Tcl_GetIntForIndex. The internal rep is |
| ︙ | ︙ | |||
489 490 491 492 493 494 495 |
TclFindElement(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
const char *list, /* Points to the first byte of a string
* containing a Tcl list with zero or more
* elements (possibly in braces). */
| | | 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 |
TclFindElement(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
const char *list, /* Points to the first byte of a string
* containing a Tcl list with zero or more
* elements (possibly in braces). */
size_t listLength, /* Number of bytes in the list's string. */
const char **elementPtr, /* Where to put address of first significant
* character in first element of list. */
const char **nextPtr, /* Fill in with location of character just
* after all white space following end of
* argument (next arg or end of list). */
size_t *sizePtr, /* If non-zero, fill in with size of
* element. */
|
| ︙ | ︙ | |||
517 518 519 520 521 522 523 |
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
const char *dict, /* Points to the first byte of a string
* containing a Tcl dictionary with zero or
* more keys and values (possibly in
* braces). */
| | | 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 |
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
const char *dict, /* Points to the first byte of a string
* containing a Tcl dictionary with zero or
* more keys and values (possibly in
* braces). */
size_t dictLength, /* Number of bytes in the dict's string. */
const char **elementPtr, /* Where to put address of first significant
* character in the first element (i.e., key
* or value) of dict. */
const char **nextPtr, /* Fill in with location of character just
* after all white space following end of
* element (next arg or end of list). */
size_t *sizePtr, /* If non-zero, fill in with size of
|
| ︙ | ︙ | |||
546 547 548 549 550 551 552 |
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
const char *string, /* Points to the first byte of a string
* containing a Tcl list or dictionary with
* zero or more elements (possibly in
* braces). */
| | | 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 |
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
const char *string, /* Points to the first byte of a string
* containing a Tcl list or dictionary with
* zero or more elements (possibly in
* braces). */
size_t stringLength, /* Number of bytes in the string. */
const char *typeStr, /* The name of the type of thing we are
* parsing, for error messages. */
const char *typeCode, /* The type code for thing we are parsing, for
* error messages. */
const char **elementPtr, /* Where to put address of first significant
* character in first element. */
const char **nextPtr, /* Fill in with location of character just
|
| ︙ | ︙ | |||
568 569 570 571 572 573 574 |
* the literal list/dict element and therefore
* does not/does require a call to
* TclCopyAndCollapse() by the caller. */
{
const char *p = string;
const char *elemStart; /* Points to first byte of first element. */
const char *limit; /* Points just after list/dict's last byte. */
| | | | 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 |
* the literal list/dict element and therefore
* does not/does require a call to
* TclCopyAndCollapse() by the caller. */
{
const char *p = string;
const char *elemStart; /* Points to first byte of first element. */
const char *limit; /* Points just after list/dict's last byte. */
size_t openBraces = 0; /* Brace nesting level during parse. */
int inQuotes = 0;
size_t size = 0;
size_t numChars;
int literal = 1;
const char *p2;
/*
* Skim off leading white space and check for an opening brace or quote.
* We treat embedded NULLs in the list/dict as bytes belonging to a list
|
| ︙ | ︙ | |||
840 841 842 843 844 845 846 847 848 849 850 851 |
*
* Side effects:
* Memory is allocated.
*
*----------------------------------------------------------------------
*/
int
Tcl_SplitList(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, no error message is left. */
const char *list, /* Pointer to string with list structure. */
| > | | | | 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 |
*
* Side effects:
* Memory is allocated.
*
*----------------------------------------------------------------------
*/
#undef Tcl_SplitList
int
Tcl_SplitList(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, no error message is left. */
const char *list, /* Pointer to string with list structure. */
size_t *argcPtr, /* Pointer to location to fill in with the
* number of elements in the list. */
const char ***argvPtr) /* Pointer to place to store pointer to array
* of pointers to list elements. */
{
const char **argv, *end, *element;
char *p;
int result;
size_t length, size, i, elSize;
/*
* Allocate enough space to work in. A (const char *) for each (possible)
* list element plus one more for terminating NULL, plus as many bytes as
* in the original string value, plus one more for a terminating '\0'.
* Space used to hold element separating white space in the original
* string gets re-purposed to hold '\0' characters in the argv array.
|
| ︙ | ︙ | |||
970 971 972 973 974 975 976 |
Tcl_ScanCountedElement(
const char *src, /* String to convert to Tcl list element. */
size_t length, /* Number of bytes in src, or -1. */
int *flagPtr) /* Where to store information to guide
* Tcl_ConvertElement. */
{
char flags = CONVERT_ANY;
| | | 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 |
Tcl_ScanCountedElement(
const char *src, /* String to convert to Tcl list element. */
size_t length, /* Number of bytes in src, or -1. */
int *flagPtr) /* Where to store information to guide
* Tcl_ConvertElement. */
{
char flags = CONVERT_ANY;
size_t numBytes = TclScanElement(src, length, &flags);
*flagPtr = flags;
return numBytes;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1014 1015 1016 1017 1018 1019 1020 |
TclScanElement(
const char *src, /* String to convert to Tcl list element. */
ssize_t length, /* Number of bytes in src, or -1. */
char *flagPtr) /* Where to store information to guide
* Tcl_ConvertElement. */
{
const char *p = src;
| | | 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 |
TclScanElement(
const char *src, /* String to convert to Tcl list element. */
ssize_t length, /* Number of bytes in src, or -1. */
char *flagPtr) /* Where to store information to guide
* Tcl_ConvertElement. */
{
const char *p = src;
size_t nestingLevel = 0; /* Brace nesting count */
int forbidNone = 0; /* Do not permit CONVERT_NONE mode. Something
* needs protection or escape. */
int requireEscape = 0; /* Force use of CONVERT_ESCAPE mode. For some
* reason bare or brace-quoted form fails. */
int extra = 0; /* Count of number of extra bytes needed for
* formatted element, assuming we use escape
* sequences in formatting. */
|
| ︙ | ︙ | |||
1083 1084 1085 1086 1087 1088 1089 | nestingLevel++; break; case '}': /* TYPE_BRACE */ #if COMPAT braceCount++; #endif /* COMPAT */ extra++; /* Escape '}' => '\}' */ | < | | 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 |
nestingLevel++;
break;
case '}': /* TYPE_BRACE */
#if COMPAT
braceCount++;
#endif /* COMPAT */
extra++; /* Escape '}' => '\}' */
if (nestingLevel-- < 1) {
/*
* Unbalanced braces! Cannot format with brace quoting.
*/
requireEscape = 1;
}
break;
|
| ︙ | ︙ | |||
1165 1166 1167 1168 1169 1170 1171 |
}
}
length -= (length+1 > 1);
p++;
}
endOfString:
| | | 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 |
}
}
length -= (length+1 > 1);
p++;
}
endOfString:
if (nestingLevel > 0) {
/*
* Unbalanced braces! Cannot format with brace quoting.
*/
requireEscape = 1;
}
|
| ︙ | ︙ | |||
1554 1555 1556 1557 1558 1559 1560 | * None. * *---------------------------------------------------------------------- */ char * Tcl_Merge( | | < | | 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 |
* None.
*
*----------------------------------------------------------------------
*/
char *
Tcl_Merge(
size_t argc, /* How many strings to merge. */
const char *const *argv) /* Array of string values. */
{
#define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
size_t i, bytesNeeded = 0;
char *result, *dst;
/*
* Handle empty list case first, so logic of the general case can be
* simpler.
*/
|
| ︙ | ︙ | |||
1843 1844 1845 1846 1847 1848 1849 | */ /* The whitespace characters trimmed during [concat] operations */ #define CONCAT_WS_SIZE (sizeof(CONCAT_TRIM_SET "") - 1) char * Tcl_Concat( | | < | | 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 |
*/
/* The whitespace characters trimmed during [concat] operations */
#define CONCAT_WS_SIZE (sizeof(CONCAT_TRIM_SET "") - 1)
char *
Tcl_Concat(
size_t argc, /* Number of strings to concatenate. */
const char *const *argv) /* Array of strings to concatenate. */
{
size_t i, needSpace = 0, bytesNeeded = 0;
char *result, *p;
/*
* Dispose of the empty result corner case first to simplify later code.
*/
if (argc == 0) {
|
| ︙ | ︙ | |||
1933 1934 1935 1936 1937 1938 1939 | * A new object is created. * *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_ConcatObj( | | | | | 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 |
* A new object is created.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_ConcatObj(
size_t objc, /* Number of objects to concatenate. */
Tcl_Obj *const objv[]) /* Array of objects to concatenate. */
{
int needSpace = 0;
size_t i, bytesNeeded = 0, elemLength;
const char *element;
Tcl_Obj *objPtr, *resPtr;
/*
* Check first to see if all the items are of list type or empty. If so,
* we will concat them together as lists, and return a list object. This
* is only valid when the lists are in canonical form.
|
| ︙ | ︙ | |||
3333 3334 3335 3336 3337 3338 3339 |
size_t endValue, /* The value to be stored at *widePtr if
* objPtr holds "end".
* NOTE: this value may be TCL_INDEX_NONE. */
Tcl_WideInt *widePtr) /* Location filled in with a wide integer
* representing an index. */
{
int numType;
| | | 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 |
size_t endValue, /* The value to be stored at *widePtr if
* objPtr holds "end".
* NOTE: this value may be TCL_INDEX_NONE. */
Tcl_WideInt *widePtr) /* Location filled in with a wide integer
* representing an index. */
{
int numType;
void *cd;
int code = TclGetNumberFromObj(NULL, objPtr, &cd, &numType);
if (code == TCL_OK) {
if (numType == TCL_NUMBER_INT) {
/* objPtr holds an integer in the signed wide range */
*widePtr = *(Tcl_WideInt *)cd;
return TCL_OK;
|
| ︙ | ︙ | |||
3452 3453 3454 3455 3456 3457 3458 |
size_t endValue, /* The value to be stored at "indexPtr" if
* "objPtr" holds "end". */
Tcl_WideInt *widePtr) /* Location filled in with an integer
* representing an index. */
{
Tcl_ObjInternalRep *irPtr;
Tcl_WideInt offset = -1; /* Offset in the "end-offset" expression - 1 */
| | | > | | 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 |
size_t endValue, /* The value to be stored at "indexPtr" if
* "objPtr" holds "end". */
Tcl_WideInt *widePtr) /* Location filled in with an integer
* representing an index. */
{
Tcl_ObjInternalRep *irPtr;
Tcl_WideInt offset = -1; /* Offset in the "end-offset" expression - 1 */
void *cd;
while ((irPtr = TclFetchInternalRep(objPtr, &endOffsetType)) == NULL) {
Tcl_ObjInternalRep ir;
size_t length;
const char *bytes = Tcl_GetStringFromObj(objPtr, &length);
if (*bytes != 'e') {
int numType;
const char *opPtr;
int t1 = 0, t2 = 0;
size_t len;
/* Value doesn't start with "e" */
/* If we reach here, the string rep of objPtr exists. */
/*
* The valid index syntax does not include any value that is
* a list of more than one element. This is necessary so that
* lists of index values can be reliably distinguished from any
* single index value.
*/
/*
* Quick scan to see if multi-value list is even possible.
* This relies on TclGetString() returning a NUL-terminated string.
*/
if ((TclMaxListLength(bytes, -1, NULL) > 1)
/* If it's possible, do the full list parse. */
&& (TCL_OK == TclListObjLengthM(NULL, objPtr, &len))
&& (len > 1)) {
goto parseError;
}
/* Passed the list screen, so parse for index arithmetic expression */
if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL, -1, &opPtr,
TCL_PARSE_INTEGER_ONLY)) {
|
| ︙ | ︙ | |||
3875 3876 3877 3878 3879 3880 3881 | * Frees a Tcl_HashTable. * *---------------------------------------------------------------------- */ static void FreeThreadHash( | | | 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 |
* Frees a Tcl_HashTable.
*
*----------------------------------------------------------------------
*/
static void
FreeThreadHash(
void *clientData)
{
Tcl_HashTable *tablePtr = (Tcl_HashTable *)clientData;
ClearHash(tablePtr);
Tcl_DeleteHashTable(tablePtr);
Tcl_Free(tablePtr);
}
|
| ︙ | ︙ | |||
3897 3898 3899 3900 3901 3902 3903 | * ProcessGlobalValue at exit. * *---------------------------------------------------------------------- */ static void FreeProcessGlobalValue( | | | 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 |
* ProcessGlobalValue at exit.
*
*----------------------------------------------------------------------
*/
static void
FreeProcessGlobalValue(
void *clientData)
{
ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *)clientData;
pgvPtr->epoch++;
pgvPtr->numBytes = 0;
Tcl_Free(pgvPtr->value);
pgvPtr->value = NULL;
|
| ︙ | ︙ |
Changes to generic/tclVar.c.
| ︙ | ︙ | |||
208 209 210 211 212 213 214 | Interp *iPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags, int index); /* * TIP #508: [array default] */ | | | 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 | Interp *iPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags, int index); /* * TIP #508: [array default] */ static int ArrayDefaultCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void DeleteArrayVar(Var *arrayPtr); static void SetArrayDefault(Var *arrayPtr, Tcl_Obj *defaultObj); /* * Functions defined in this file that may be exported in the future for use |
| ︙ | ︙ | |||
264 265 266 267 268 269 270 |
} while (0)
#define LocalGetInternalRep(objPtr, index, name) \
do { \
const Tcl_ObjInternalRep *irPtr; \
irPtr = TclFetchInternalRep((objPtr), &localVarNameType); \
(name) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr1 : NULL; \
| | | 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 |
} while (0)
#define LocalGetInternalRep(objPtr, index, name) \
do { \
const Tcl_ObjInternalRep *irPtr; \
irPtr = TclFetchInternalRep((objPtr), &localVarNameType); \
(name) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr1 : NULL; \
(index) = irPtr ? PTR2UINT(irPtr->twoPtrValue.ptr2) : TCL_INDEX_NONE; \
} while (0)
static const Tcl_ObjType parsedVarNameType = {
"parsedVarName",
FreeParsedVarName, DupParsedVarName, NULL, NULL
};
|
| ︙ | ︙ | |||
605 606 607 608 609 610 611 |
Interp *iPtr = (Interp *) interp;
CallFrame *varFramePtr = iPtr->varFramePtr;
Var *varPtr; /* Points to the variable's in-frame Var
* structure. */
const char *errMsg = NULL;
int index, parsed = 0;
| | | | 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 |
Interp *iPtr = (Interp *) interp;
CallFrame *varFramePtr = iPtr->varFramePtr;
Var *varPtr; /* Points to the variable's in-frame Var
* structure. */
const char *errMsg = NULL;
int index, parsed = 0;
size_t localIndex;
Tcl_Obj *namePtr, *arrayPtr, *elem;
*arrayPtrPtr = NULL;
restart:
LocalGetInternalRep(part1Ptr, localIndex, namePtr);
if (localIndex != TCL_INDEX_NONE) {
if (HasLocalVars(varFramePtr)
&& !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
&& (localIndex < varFramePtr->numCompiledLocals)) {
/*
* Use the cached index if the names coincide.
*/
|
| ︙ | ︙ | |||
2808 2809 2810 2811 2812 2813 2814 |
Tcl_LappendObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *varValuePtr, *newValuePtr;
| | | | | 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 2841 2842 2843 2844 2845 |
Tcl_LappendObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *varValuePtr, *newValuePtr;
size_t numElems;
Var *varPtr, *arrayPtr;
int result, createdNewObj;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?value ...?");
return TCL_ERROR;
}
if (objc == 2) {
newValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
if (newValuePtr == NULL) {
/*
* The variable doesn't exist yet. Just create it with an empty
* initial value.
*/
TclNewObj(varValuePtr);
newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr,
TCL_LEAVE_ERR_MSG);
if (newValuePtr == NULL) {
return TCL_ERROR;
}
} else {
result = TclListObjLengthM(interp, newValuePtr, &numElems);
if (result != TCL_OK) {
return result;
}
}
} else {
/*
* We have arguments to append. We used to call Tcl_SetVar2 to append
|
| ︙ | ︙ | |||
2889 2890 2891 2892 2893 2894 2895 |
TclNewObj(varValuePtr);
createdNewObj = 1;
} else if (Tcl_IsShared(varValuePtr)) {
varValuePtr = Tcl_DuplicateObj(varValuePtr);
createdNewObj = 1;
}
| | | 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 |
TclNewObj(varValuePtr);
createdNewObj = 1;
} else if (Tcl_IsShared(varValuePtr)) {
varValuePtr = Tcl_DuplicateObj(varValuePtr);
createdNewObj = 1;
}
result = TclListObjLengthM(interp, varValuePtr, &numElems);
if (result == TCL_OK) {
result = Tcl_ListObjReplace(interp, varValuePtr, numElems, 0,
(objc-2), (objv+2));
}
if (result != TCL_OK) {
if (createdNewObj) {
TclDecrRefCount(varValuePtr); /* Free unneeded obj. */
|
| ︙ | ︙ | |||
3008 3009 3010 3011 3012 3013 3014 |
*valuePtrPtr = valueObj;
return donerc;
}
static int
ArrayForObjCmd(
| | | > | | 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 |
*valuePtrPtr = valueObj;
return donerc;
}
static int
ArrayForObjCmd(
void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, ArrayForNRCmd, clientData, objc, objv);
}
static int
ArrayForNRCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *varListObj, *arrayNameObj, *scriptObj;
ArraySearch *searchPtr = NULL;
Var *varPtr;
int isArray;
size_t numVars;
/*
* array for {k v} a body
*/
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "{key value} arrayName script");
return TCL_ERROR;
}
/*
* Parse arguments.
*/
if (TclListObjLengthM(interp, objv[1], &numVars) != TCL_OK) {
return TCL_ERROR;
}
if (numVars != 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must have two variable names", -1));
Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "array", "for", NULL);
|
| ︙ | ︙ | |||
3089 3090 3091 3092 3093 3094 3095 |
TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj,
arrayNameObj, scriptObj);
return TCL_OK;
}
static int
ArrayForLoopCallback(
| | | > | 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 |
TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj,
arrayNameObj, scriptObj);
return TCL_OK;
}
static int
ArrayForLoopCallback(
void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
ArraySearch *searchPtr = (ArraySearch *)data[0];
Tcl_Obj *varListObj = (Tcl_Obj *)data[1];
Tcl_Obj *arrayNameObj = (Tcl_Obj *)data[2];
Tcl_Obj *scriptObj = (Tcl_Obj *)data[3];
Tcl_Obj **varv;
Tcl_Obj *keyObj, *valueObj;
Var *varPtr;
Var *arrayPtr;
int done;
size_t varc;
/*
* Process the result from the previous execution of the script body.
*/
done = TCL_ERROR;
|
| ︙ | ︙ | |||
3152 3153 3154 3155 3156 3157 3158 |
Tcl_SetErrorCode(interp, "TCL", "READ", "array", "for", NULL);
varPtr->flags |= TCL_LEAVE_ERR_MSG;
result = done;
}
goto arrayfordone;
}
| | | 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 |
Tcl_SetErrorCode(interp, "TCL", "READ", "array", "for", NULL);
varPtr->flags |= TCL_LEAVE_ERR_MSG;
result = done;
}
goto arrayfordone;
}
TclListObjGetElementsM(NULL, varListObj, &varc, &varv);
if (Tcl_ObjSetVar2(interp, varv[0], NULL, keyObj,
TCL_LEAVE_ERR_MSG) == NULL) {
result = TCL_ERROR;
goto arrayfordone;
}
if (valueObj != NULL) {
if (Tcl_ObjSetVar2(interp, varv[1], NULL, valueObj,
|
| ︙ | ︙ | |||
3610 3611 3612 3613 3614 3615 3616 |
Tcl_Obj *const objv[])
{
Var *varPtr, *varPtr2;
Tcl_Obj *varNameObj, *nameObj, *valueObj, *nameLstObj, *tmpResObj;
Tcl_Obj **nameObjPtr, *patternObj;
Tcl_HashSearch search;
const char *pattern;
| > | | 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 |
Tcl_Obj *const objv[])
{
Var *varPtr, *varPtr2;
Tcl_Obj *varNameObj, *nameObj, *valueObj, *nameLstObj, *tmpResObj;
Tcl_Obj **nameObjPtr, *patternObj;
Tcl_HashSearch search;
const char *pattern;
size_t i, count;
int result, isArray;
switch (objc) {
case 2:
varNameObj = objv[1];
patternObj = NULL;
break;
case 3:
|
| ︙ | ︙ | |||
3692 3693 3694 3695 3696 3697 3698 |
}
/*
* Get the array values corresponding to each element name.
*/
TclNewObj(tmpResObj);
| | | 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 |
}
/*
* Get the array values corresponding to each element name.
*/
TclNewObj(tmpResObj);
result = TclListObjGetElementsM(interp, nameLstObj, &count, &nameObjPtr);
if (result != TCL_OK) {
goto errorInArrayGet;
}
for (i=0 ; i<count ; i++) {
nameObj = *nameObjPtr++;
valueObj = Tcl_ObjGetVar2(interp, varNameObj, nameObj,
|
| ︙ | ︙ | |||
3902 3903 3904 3905 3906 3907 3908 |
Tcl_Obj *nameObj;
int dummy;
if (TclIsVarUndefined(varPtr)) {
continue;
}
nameObj = VarHashGetKey(varPtr);
| | | 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 |
Tcl_Obj *nameObj;
int dummy;
if (TclIsVarUndefined(varPtr)) {
continue;
}
nameObj = VarHashGetKey(varPtr);
hPtr = Tcl_CreateHashEntry(tablePtr, nameObj, &dummy);
Tcl_SetHashValue(hPtr, nameObj);
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3934 3935 3936 3937 3938 3939 3940 |
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *arrayNameObj;
Tcl_Obj *arrayElemObj;
Var *varPtr, *arrayPtr;
| | > | 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 |
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *arrayNameObj;
Tcl_Obj *arrayElemObj;
Var *varPtr, *arrayPtr;
int result;
size_t i;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "arrayName list");
return TCL_ERROR;
}
if (TCL_ERROR == LocateArray(interp, objv[1], NULL, NULL)) {
|
| ︙ | ︙ | |||
3969 3970 3971 3972 3973 3974 3975 3976 |
*/
arrayElemObj = objv[2];
if (TclHasInternalRep(arrayElemObj, &tclDictType) && arrayElemObj->bytes == NULL) {
Tcl_Obj *keyPtr, *valuePtr;
Tcl_DictSearch search;
int done;
| > | | | 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 |
*/
arrayElemObj = objv[2];
if (TclHasInternalRep(arrayElemObj, &tclDictType) && arrayElemObj->bytes == NULL) {
Tcl_Obj *keyPtr, *valuePtr;
Tcl_DictSearch search;
int done;
size_t size;
if (Tcl_DictObjSize(interp, arrayElemObj, &size) != TCL_OK) {
return TCL_ERROR;
}
if (size == 0) {
/*
* Empty, so we'll just force the array to be properly existing
* instead.
*/
goto ensureArray;
}
|
| ︙ | ︙ | |||
4012 4013 4014 4015 4016 4017 4018 |
return TCL_OK;
} else {
/*
* Not a dictionary, so assume (and convert to, for backward-
* -compatibility reasons) a list.
*/
| | | | 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 |
return TCL_OK;
} else {
/*
* Not a dictionary, so assume (and convert to, for backward-
* -compatibility reasons) a list.
*/
size_t elemLen;
Tcl_Obj **elemPtrs, *copyListObj;
result = TclListObjGetElementsM(interp, arrayElemObj,
&elemLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
if (elemLen & 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"list must have an even number of elements", -1));
|
| ︙ | ︙ | |||
4101 4102 4103 4104 4105 4106 4107 | * See the user documentation. * *---------------------------------------------------------------------- */ static int ArraySizeCmd( | | | 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArraySizeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Var *varPtr;
Tcl_HashSearch search;
Var *varPtr2;
|
| ︙ | ︙ | |||
4160 4161 4162 4163 4164 4165 4166 | * See the user documentation. * *---------------------------------------------------------------------- */ static int ArrayStatsCmd( | | | 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayStatsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Var *varPtr;
Tcl_Obj *varNameObj;
char *stats;
|
| ︙ | ︙ | |||
4214 4215 4216 4217 4218 4219 4220 | * See the user documentation. * *---------------------------------------------------------------------- */ static int ArrayUnsetCmd( | | | 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayUnsetCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Var *varPtr, *varPtr2, *protectedVarPtr;
Tcl_Obj *varNameObj, *patternObj, *nameObj;
Tcl_HashSearch search;
|
| ︙ | ︙ | |||
4754 4755 4756 4757 4758 4759 4760 |
}
if (TclIsVarInHash(varPtr)) {
if (!TclIsVarDeadHash(varPtr)) {
namePtr = VarHashGetKey(varPtr);
Tcl_AppendObjToObj(objPtr, namePtr);
}
} else if (iPtr->varFramePtr->procPtr) {
| | | | 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 |
}
if (TclIsVarInHash(varPtr)) {
if (!TclIsVarDeadHash(varPtr)) {
namePtr = VarHashGetKey(varPtr);
Tcl_AppendObjToObj(objPtr, namePtr);
}
} else if (iPtr->varFramePtr->procPtr) {
size_t index = varPtr - iPtr->varFramePtr->compiledLocals;
if (index < iPtr->varFramePtr->numCompiledLocals) {
namePtr = localName(iPtr->varFramePtr, index);
Tcl_AppendObjToObj(objPtr, namePtr);
}
}
}
/*
|
| ︙ | ︙ | |||
4782 4783 4784 4785 4786 4787 4788 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_GlobalObjCmd( | | | 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GlobalObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *objPtr, *tailPtr;
const char *varName;
|
| ︙ | ︙ | |||
4886 4887 4888 4889 4890 4891 4892 | * result in the interpreter's result object. * *---------------------------------------------------------------------- */ int Tcl_VariableObjCmd( | | | 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 |
* result in the interpreter's result object.
*
*----------------------------------------------------------------------
*/
int
Tcl_VariableObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
const char *varName, *tail, *cp;
Var *varPtr, *arrayPtr;
|
| ︙ | ︙ | |||
5019 5020 5021 5022 5023 5024 5025 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_UpvarObjCmd( | | | 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_UpvarObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
CallFrame *framePtr;
int result, hasLevel;
Tcl_Obj *levelObj;
|
| ︙ | ︙ | |||
5380 5381 5382 5383 5384 5385 5386 |
void
TclDeleteCompiledLocalVars(
Interp *iPtr, /* Interpreter to which variables belong. */
CallFrame *framePtr) /* Procedure call frame containing compiler-
* assigned local variables to delete. */
{
Var *varPtr;
| | | 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 |
void
TclDeleteCompiledLocalVars(
Interp *iPtr, /* Interpreter to which variables belong. */
CallFrame *framePtr) /* Procedure call frame containing compiler-
* assigned local variables to delete. */
{
Var *varPtr;
size_t numLocals, i;
Tcl_Obj **namePtrPtr;
numLocals = framePtr->numCompiledLocals;
varPtr = framePtr->compiledLocals;
namePtrPtr = &localName(framePtr, 0);
for (i=0 ; i<numLocals ; i++, namePtrPtr++, varPtr++) {
UnsetVarStruct(varPtr, NULL, iPtr, *namePtrPtr, NULL,
|
| ︙ | ︙ | |||
5578 5579 5580 5581 5582 5583 5584 |
* twoPtrValue.ptr2: index into locals table
*/
static void
FreeLocalVarName(
Tcl_Obj *objPtr)
{
| | | | 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 |
* twoPtrValue.ptr2: index into locals table
*/
static void
FreeLocalVarName(
Tcl_Obj *objPtr)
{
size_t index;
Tcl_Obj *namePtr;
LocalGetInternalRep(objPtr, index, namePtr);
index++; /* Compiler warning bait. */
if (namePtr) {
Tcl_DecrRefCount(namePtr);
}
}
static void
DupLocalVarName(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
size_t index;
Tcl_Obj *namePtr;
LocalGetInternalRep(srcPtr, index, namePtr);
if (!namePtr) {
namePtr = srcPtr;
}
LocalSetInternalRep(dupPtr, index, namePtr);
|
| ︙ | ︙ | |||
5835 5836 5837 5838 5839 5840 5841 | * error, the result is an error message. * *---------------------------------------------------------------------- */ int TclInfoVarsCmd( | | | 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
int
TclInfoVarsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
const char *varName, *pattern, *simplePattern;
Tcl_HashSearch search;
|
| ︙ | ︙ | |||
6026 6027 6028 6029 6030 6031 6032 | * error, the result is an error message. * *---------------------------------------------------------------------- */ int TclInfoGlobalsCmd( | | | 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
int
TclInfoGlobalsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *varName, *pattern;
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
Tcl_HashSearch search;
|
| ︙ | ︙ | |||
6119 6120 6121 6122 6123 6124 6125 | * error, the result is an error message. * *---------------------------------------------------------------------- */ int TclInfoLocalsCmd( | | | 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
int
TclInfoLocalsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *patternPtr, *listPtr;
|
| ︙ | ︙ | |||
6178 6179 6180 6181 6182 6183 6184 |
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *listPtr, /* List object to append names to. */
Tcl_Obj *patternPtr, /* Pattern to match against. */
int includeLinks) /* 1 if upvars should be included, else 0. */
{
Interp *iPtr = (Interp *) interp;
Var *varPtr;
| | > | 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 |
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *listPtr, /* List object to append names to. */
Tcl_Obj *patternPtr, /* Pattern to match against. */
int includeLinks) /* 1 if upvars should be included, else 0. */
{
Interp *iPtr = (Interp *) interp;
Var *varPtr;
size_t i, localVarCt;
int added;
Tcl_Obj *objNamePtr;
const char *varName;
TclVarHashTable *localVarTablePtr;
Tcl_HashSearch search;
Tcl_HashTable addedTable;
const char *pattern = patternPtr? TclGetString(patternPtr) : NULL;
|
| ︙ | ︙ | |||
6424 6425 6426 6427 6428 6429 6430 | * See the user documentation. * *---------------------------------------------------------------------- */ static int ArrayDefaultCmd( | | | 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayDefaultCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const options[] = {
"get", "set", "exists", "unset", NULL
};
|
| ︙ | ︙ |
Changes to generic/tclZipfs.c.
| ︙ | ︙ | |||
345 346 347 348 349 350 351 | static int ZipFSFileAttrsSetProc(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr); static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); static int ZipMapArchive(Tcl_Interp *interp, ZipFile *zf, void *handle); | | | | 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 | static int ZipFSFileAttrsSetProc(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr); static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); static int ZipMapArchive(Tcl_Interp *interp, ZipFile *zf, void *handle); static void ZipfsExitHandler(void *clientData); static void ZipfsMountExitHandler(void *clientData); static void ZipfsSetup(void); static void ZipfsFinalize(void); static int ZipChannelClose(void *instanceData, Tcl_Interp *interp, int flags); static Tcl_DriverGetHandleProc ZipChannelGetFile; static int ZipChannelRead(void *instanceData, char *buf, int toRead, int *errloc); |
| ︙ | ︙ | |||
406 407 408 409 410 411 412 |
/*
* The channel type/driver definition used for ZIP archive members.
*/
static Tcl_ChannelType ZipChannelType = {
"zip", /* Type name. */
TCL_CHANNEL_VERSION_5,
| | | 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 |
/*
* The channel type/driver definition used for ZIP archive members.
*/
static Tcl_ChannelType ZipChannelType = {
"zip", /* Type name. */
TCL_CHANNEL_VERSION_5,
NULL, /* Close channel, clean instance data */
ZipChannelRead, /* Handle read request */
ZipChannelWrite, /* Handle write request */
NULL, /* Move location of access point, NULL'able */
NULL, /* Set options, NULL'able */
NULL, /* Get options, NULL'able */
ZipChannelWatchChannel, /* Initialize notifier */
ZipChannelGetFile, /* Get OS handle from the channel */
|
| ︙ | ︙ | |||
2212 2213 2214 2215 2216 2217 2218 | * A ZIP archive file is mounted, resources are allocated. * *------------------------------------------------------------------------- */ static int ZipFSMountObjCmd( | | | 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 |
* A ZIP archive file is mounted, resources are allocated.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSMountObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *mountPoint = NULL, *zipFile = NULL, *password = NULL;
Tcl_Obj *zipFileObj = NULL;
int result;
|
| ︙ | ︙ | |||
2269 2270 2271 2272 2273 2274 2275 | * A ZIP archive file is mounted, resources are allocated. * *------------------------------------------------------------------------- */ static int ZipFSMountBufferObjCmd( | | | 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 |
* A ZIP archive file is mounted, resources are allocated.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSMountBufferObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *mountPoint; /* Mount point path. */
unsigned char *data;
size_t length;
|
| ︙ | ︙ | |||
2324 2325 2326 2327 2328 2329 2330 | * Side effects: * *------------------------------------------------------------------------- */ static int ZipFSRootObjCmd( | | | 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 |
* Side effects:
*
*-------------------------------------------------------------------------
*/
static int
ZipFSRootObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *)) /*objv*/
{
Tcl_SetObjResult(interp, Tcl_NewStringObj(ZIPFS_VOLUME, -1));
return TCL_OK;
}
|
| ︙ | ︙ | |||
2351 2352 2353 2354 2355 2356 2357 | * A mounted ZIP archive file is unmounted, resources are free'd. * *------------------------------------------------------------------------- */ static int ZipFSUnmountObjCmd( | | | 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 |
* A mounted ZIP archive file is unmounted, resources are free'd.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSUnmountObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "zipfile");
return TCL_ERROR;
|
| ︙ | ︙ | |||
2382 2383 2384 2385 2386 2387 2388 | * None. * *------------------------------------------------------------------------- */ static int ZipFSMkKeyObjCmd( | | | 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSMkKeyObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int len, i = 0;
const char *pw;
Tcl_Obj *passObj;
|
| ︙ | ︙ | |||
2986 2987 2988 2989 2990 2991 2992 |
* filenames found beneath dirRoot? If NULL,
* do not strip anything (except for dirRoot
* itself). */
Tcl_Obj *passwordObj) /* The password for encoding things. NULL if
* there's no password protection. */
{
Tcl_Channel out;
| | | | 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 |
* filenames found beneath dirRoot? If NULL,
* do not strip anything (except for dirRoot
* itself). */
Tcl_Obj *passwordObj) /* The password for encoding things. NULL if
* there's no password protection. */
{
Tcl_Channel out;
int pwlen = 0, slen = 0, count, ret = TCL_ERROR;
size_t lobjc, len, i = 0;
long long directoryStartOffset;
/* The overall file offset of the start of the
* central directory. */
long long suffixStartOffset;/* The overall file offset of the start of the
* suffix of the central directory (i.e.,
* where this data will be written). */
Tcl_Obj **lobjv, *list = mappingList;
|
| ︙ | ︙ | |||
3025 3026 3027 3028 3029 3030 3031 |
if (dirRoot != NULL) {
list = ZipFSFind(interp, dirRoot);
if (!list) {
return TCL_ERROR;
}
}
Tcl_IncrRefCount(list);
| | | 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 |
if (dirRoot != NULL) {
list = ZipFSFind(interp, dirRoot);
if (!list) {
return TCL_ERROR;
}
}
Tcl_IncrRefCount(list);
if (TclListObjGetElementsM(interp, list, &lobjc, &lobjv) != TCL_OK) {
Tcl_DecrRefCount(list);
return TCL_ERROR;
}
if (mappingList && (lobjc % 2)) {
Tcl_DecrRefCount(list);
ZIPFS_ERROR(interp, "need even number of elements");
ZIPFS_ERROR_CODE(interp, "LIST_LENGTH");
|
| ︙ | ︙ | |||
3454 3455 3456 3457 3458 3459 3460 | * See description of ZipFSMkZipOrImg(). * *------------------------------------------------------------------------- */ static int ZipFSMkZipObjCmd( | | | 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 |
* See description of ZipFSMkZipOrImg().
*
*-------------------------------------------------------------------------
*/
static int
ZipFSMkZipObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *stripPrefix, *password;
if (objc < 3 || objc > 5) {
|
| ︙ | ︙ | |||
3479 3480 3481 3482 3483 3484 3485 |
password = (objc > 4 ? objv[4] : NULL);
return ZipFSMkZipOrImg(interp, 0, objv[1], objv[2], NULL, NULL,
stripPrefix, password);
}
static int
ZipFSLMkZipObjCmd(
| | | 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 |
password = (objc > 4 ? objv[4] : NULL);
return ZipFSMkZipOrImg(interp, 0, objv[1], objv[2], NULL, NULL,
stripPrefix, password);
}
static int
ZipFSLMkZipObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *password;
if (objc < 3 || objc > 4) {
|
| ︙ | ︙ | |||
3520 3521 3522 3523 3524 3525 3526 | * See description of ZipFSMkZipOrImg(). * *------------------------------------------------------------------------- */ static int ZipFSMkImgObjCmd( | | | 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 |
* See description of ZipFSMkZipOrImg().
*
*-------------------------------------------------------------------------
*/
static int
ZipFSMkImgObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *originFile, *stripPrefix, *password;
if (objc < 3 || objc > 6) {
|
| ︙ | ︙ | |||
3547 3548 3549 3550 3551 3552 3553 |
password = (objc > 4 ? objv[4] : NULL);
return ZipFSMkZipOrImg(interp, 1, objv[1], objv[2], NULL,
originFile, stripPrefix, password);
}
static int
ZipFSLMkImgObjCmd(
| | | 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 |
password = (objc > 4 ? objv[4] : NULL);
return ZipFSMkZipOrImg(interp, 1, objv[1], objv[2], NULL,
originFile, stripPrefix, password);
}
static int
ZipFSLMkImgObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *originFile, *password;
if (objc < 3 || objc > 5) {
|
| ︙ | ︙ | |||
3589 3590 3591 3592 3593 3594 3595 | * None. * *------------------------------------------------------------------------- */ static int ZipFSCanonicalObjCmd( | | | 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSCanonicalObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
char *mntpoint = NULL;
char *filename = NULL;
char *result;
|
| ︙ | ︙ | |||
3645 3646 3647 3648 3649 3650 3651 | * None. * *------------------------------------------------------------------------- */ static int ZipFSExistsObjCmd( | | | 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSExistsObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
char *filename;
int exists;
Tcl_DString ds;
|
| ︙ | ︙ | |||
3698 3699 3700 3701 3702 3703 3704 | * None. * *------------------------------------------------------------------------- */ static int ZipFSInfoObjCmd( | | | 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSInfoObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
char *filename;
ZipEntry *z;
|
| ︙ | ︙ | |||
3748 3749 3750 3751 3752 3753 3754 | * None. * *------------------------------------------------------------------------- */ static int ZipFSListObjCmd( | | | 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSListObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
char *pattern = NULL;
Tcl_RegExp regexp = NULL;
Tcl_HashEntry *hPtr;
|
| ︙ | ︙ | |||
3947 3948 3949 3950 3951 3952 3953 | * This cache is never cleared. * *------------------------------------------------------------------------- */ static int ZipFSTclLibraryObjCmd( | | | 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 |
* This cache is never cleared.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSTclLibraryObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *)) /*objv*/
{
if (!Tcl_IsSafe(interp)) {
Tcl_Obj *pResult = TclZipfs_TclLibrary();
|
| ︙ | ︙ | |||
4237 4238 4239 4240 4241 4242 4243 | * None. * *------------------------------------------------------------------------- */ static void ZipChannelWatchChannel( | | | 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 |
* None.
*
*-------------------------------------------------------------------------
*/
static void
ZipChannelWatchChannel(
TCL_UNUSED(void *),
TCL_UNUSED(int) /*mask*/)
{
return;
}
/*
*-------------------------------------------------------------------------
|
| ︙ | ︙ | |||
4262 4263 4264 4265 4266 4267 4268 | * None. * *------------------------------------------------------------------------- */ static int ZipChannelGetFile( | | | | 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
ZipChannelGetFile(
TCL_UNUSED(void *),
TCL_UNUSED(int) /*direction*/,
TCL_UNUSED(void **) /*handlePtr*/)
{
return TCL_ERROR;
}
/*
*-------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
5207 5208 5209 5210 5211 5212 5213 |
*
*-------------------------------------------------------------------------
*/
static int
ZipFSPathInFilesystemProc(
Tcl_Obj *pathPtr,
| | | 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 |
*
*-------------------------------------------------------------------------
*/
static int
ZipFSPathInFilesystemProc(
Tcl_Obj *pathPtr,
TCL_UNUSED(void **))
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
int ret = -1, len;
char *path;
pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
|
| ︙ | ︙ | |||
5723 5724 5725 5726 5727 5728 5729 |
return TCL_ERROR;
}
#endif
static void
ZipfsExitHandler(
| | | 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 |
return TCL_ERROR;
}
#endif
static void
ZipfsExitHandler(
TCL_UNUSED(void *)
)
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
if (ZipFS.initialized != -1) {
hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
if (hPtr == NULL) {
|
| ︙ | ︙ | |||
5749 5750 5751 5752 5753 5754 5755 |
Tcl_DeleteHashTable(&ZipFS.fileHash);
Tcl_Free(ZipFS.fallbackEntryEncoding);
ZipFS.initialized = -1;
}
static void
ZipfsMountExitHandler(
| | | 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 |
Tcl_DeleteHashTable(&ZipFS.fileHash);
Tcl_Free(ZipFS.fallbackEntryEncoding);
ZipFS.initialized = -1;
}
static void
ZipfsMountExitHandler(
void *clientData)
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
ZipFile *zf = (ZipFile *) clientData;
if (TCL_OK != TclZipfs_Unmount(NULL, zf->mountPoint)) {
|
| ︙ | ︙ |
Changes to generic/tclZlib.c.
| ︙ | ︙ | |||
1323 1324 1325 1326 1327 1328 1329 |
Tcl_ZlibStreamGet(
Tcl_ZlibStream zshandle, /* As obtained from Tcl_ZlibStreamInit */
Tcl_Obj *data, /* A place to append the data. */
size_t count) /* Number of bytes to grab as a maximum, you
* may get less! */
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
| | | | 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 |
Tcl_ZlibStreamGet(
Tcl_ZlibStream zshandle, /* As obtained from Tcl_ZlibStreamInit */
Tcl_Obj *data, /* A place to append the data. */
size_t count) /* Number of bytes to grab as a maximum, you
* may get less! */
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
int e;
size_t listLen, i, itemLen = 0, dataPos = 0;
Tcl_Obj *itemObj;
unsigned char *dataPtr, *itemPtr;
size_t existing = 0;
/*
* Getting beyond the of stream, just return empty string.
*/
|
| ︙ | ︙ | |||
1369 1370 1371 1372 1373 1374 1375 |
* zlib will probably need more data to decompress.
*/
if (zshPtr->currentInput) {
Tcl_DecrRefCount(zshPtr->currentInput);
zshPtr->currentInput = NULL;
}
| | | 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 |
* zlib will probably need more data to decompress.
*/
if (zshPtr->currentInput) {
Tcl_DecrRefCount(zshPtr->currentInput);
zshPtr->currentInput = NULL;
}
TclListObjLengthM(NULL, zshPtr->inData, &listLen);
if (listLen > 0) {
/*
* There is more input available, get it from the list and
* give it to zlib. At this point, the data must not be shared
* since we require the bytearray representation to not vanish
* under our feet. [Bug 3081008]
*/
|
| ︙ | ︙ | |||
1418 1419 1420 1421 1422 1423 1424 |
if (e == Z_NEED_DICT && HaveDictToSet(zshPtr)) {
e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj);
if (e == Z_OK) {
DictWasSet(zshPtr);
e = inflate(&zshPtr->stream, zshPtr->flush);
}
};
| | | 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 |
if (e == Z_NEED_DICT && HaveDictToSet(zshPtr)) {
e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj);
if (e == Z_OK) {
DictWasSet(zshPtr);
e = inflate(&zshPtr->stream, zshPtr->flush);
}
};
TclListObjLengthM(NULL, zshPtr->inData, &listLen);
while ((zshPtr->stream.avail_out > 0)
&& (e == Z_OK || e == Z_BUF_ERROR) && (listLen > 0)) {
/*
* State: We have not satisfied the request yet and there may be
* more to inflate.
*/
|
| ︙ | ︙ | |||
1498 1499 1500 1501 1502 1503 1504 |
if (zshPtr->currentInput) {
Tcl_DecrRefCount(zshPtr->currentInput);
zshPtr->currentInput = 0;
}
inflateEnd(&zshPtr->stream);
}
} else {
| | | 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 |
if (zshPtr->currentInput) {
Tcl_DecrRefCount(zshPtr->currentInput);
zshPtr->currentInput = 0;
}
inflateEnd(&zshPtr->stream);
}
} else {
TclListObjLengthM(NULL, zshPtr->outData, &listLen);
if (count == TCL_INDEX_NONE) {
count = 0;
for (i=0; i<listLen; i++) {
Tcl_ListObjIndex(NULL, zshPtr->outData, i, &itemObj);
(void) Tcl_GetByteArrayFromObj(itemObj, &itemLen);
if (i == 0) {
count += itemLen - zshPtr->outPos;
|
| ︙ | ︙ | |||
1520 1521 1522 1523 1524 1525 1526 | * Prepare the place to store the data. */ dataPtr = Tcl_SetByteArrayLength(data, existing + count); dataPtr += existing; while ((count > dataPos) && | | | 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 |
* Prepare the place to store the data.
*/
dataPtr = Tcl_SetByteArrayLength(data, existing + count);
dataPtr += existing;
while ((count > dataPos) &&
(TclListObjLengthM(NULL, zshPtr->outData, &listLen) == TCL_OK)
&& (listLen > 0)) {
/*
* Get the next chunk off our list of chunks and grab the data out
* of it.
*/
Tcl_ListObjIndex(NULL, zshPtr->outData, 0, &itemObj);
|
| ︙ | ︙ | |||
2405 2406 2407 2408 2409 2410 2411 |
};
static const char *const pushDecompressOptions[] = {
"-dictionary", "-header", "-level", "-limit", NULL
};
const char *const *pushOptions = pushDecompressOptions;
enum pushOptionsEnum {poDictionary, poHeader, poLevel, poLimit} option;
Tcl_Obj *headerObj = NULL, *compDictObj = NULL;
| | > | 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 |
};
static const char *const pushDecompressOptions[] = {
"-dictionary", "-header", "-level", "-limit", NULL
};
const char *const *pushOptions = pushDecompressOptions;
enum pushOptionsEnum {poDictionary, poHeader, poLevel, poLimit} option;
Tcl_Obj *headerObj = NULL, *compDictObj = NULL;
int limit = DEFAULT_BUFFER_SIZE;
size_t dummy;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv, "mode channel ?options...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0,
|
| ︙ | ︙ |
Changes to library/http/http.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # http.tcl -- # # Client-side HTTP for GET, POST, and HEAD commands. These routines can # be used in untrusted code that uses the Safesock security policy. # These procedures use a callback interface to avoid using vwait, which # is not defined in the safe base. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require Tcl 8.6- # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles | | > | 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 |
# http.tcl --
#
# Client-side HTTP for GET, POST, and HEAD commands. These routines can
# be used in untrusted code that uses the Safesock security policy.
# These procedures use a callback interface to avoid using vwait, which
# is not defined in the safe base.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require Tcl 8.6-
# Keep this in sync with pkgIndex.tcl and with the install directories in
# Makefiles
package provide http 2.10a4
namespace eval http {
# Allow resourcing to not clobber existing data
variable http
if {![info exists http]} {
array set http {
-accept */*
-cookiejar {}
-pipeline 1
-postfresh 0
-proxyhost {}
-proxyport {}
-proxyfilter http::ProxyRequired
-repost 0
-threadlevel 0
-urlencoding utf-8
-zip 1
}
# We need a useragent string of this style or various servers will
# refuse to send us compressed content even when we ask for it. This
# follows the de-facto layout of user-agent strings in current browsers.
# Safe interpreters do not have ::tcl_platform(os) or
|
| ︙ | ︙ | |||
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 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 |
# Create a map for HTTP/1.1 open sockets
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketClosing
variable socketPlayCmd
if {[info exists socketMapping]} {
# Close open sockets on re-init. Do not permit retries.
foreach {url sock} [array get socketMapping] {
unset -nocomplain socketClosing($url)
unset -nocomplain socketPlayCmd($url)
CloseSocket $sock
}
}
# CloseSocket should have unset the socket* arrays, one element at
# a time. Now unset anything that was overlooked.
# Traces on "unset socketRdState(*)" will call CancelReadPipeline and
# cancel any queued responses.
# Traces on "unset socketWrState(*)" will call CancelWritePipeline and
# cancel any queued requests.
array unset socketMapping
array unset socketRdState
array unset socketWrState
array unset socketRdQueue
array unset socketWrQueue
array unset socketClosing
array unset socketPlayCmd
array set socketMapping {}
array set socketRdState {}
array set socketWrState {}
array set socketRdQueue {}
array set socketWrQueue {}
array set socketClosing {}
array set socketPlayCmd {}
}
init
variable urlTypes
if {![info exists urlTypes]} {
| > > > > > > > | | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 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 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 |
# Create a map for HTTP/1.1 open sockets
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketPhQueue
variable socketClosing
variable socketPlayCmd
variable socketCoEvent
if {[info exists socketMapping]} {
# Close open sockets on re-init. Do not permit retries.
foreach {url sock} [array get socketMapping] {
unset -nocomplain socketClosing($url)
unset -nocomplain socketPlayCmd($url)
CloseSocket $sock
}
}
# CloseSocket should have unset the socket* arrays, one element at
# a time. Now unset anything that was overlooked.
# Traces on "unset socketRdState(*)" will call CancelReadPipeline and
# cancel any queued responses.
# Traces on "unset socketWrState(*)" will call CancelWritePipeline and
# cancel any queued requests.
array unset socketMapping
array unset socketRdState
array unset socketWrState
array unset socketRdQueue
array unset socketWrQueue
array unset socketPhQueue
array unset socketClosing
array unset socketPlayCmd
array unset socketCoEvent
array set socketMapping {}
array set socketRdState {}
array set socketWrState {}
array set socketRdQueue {}
array set socketWrQueue {}
array set socketPhQueue {}
array set socketClosing {}
array set socketPlayCmd {}
array set socketCoEvent {}
return
}
init
variable urlTypes
if {![info exists urlTypes]} {
set urlTypes(http) [list 80 ::http::socket]
}
variable encodings [string tolower [encoding names]]
# This can be changed, but iso8859-1 is the RFC standard.
variable defaultCharset
if {![info exists defaultCharset]} {
set defaultCharset "iso8859-1"
|
| ︙ | ︙ | |||
135 136 137 138 139 140 141 142 143 144 145 146 147 148 |
= # LITERAL: Equal sign
([!\u0023-+\u002D-:<-\u005B\u005D-~]*) # Match the value
(?:
\s* ; \s* # LITERAL: semicolon
([^\u0000]+) # Match the options
)?
}
namespace export geturl config reset wait formatQuery quoteString
namespace export register unregister registerError
# - Useful, but not exported: data, size, status, code, cleanup, error,
# meta, ncode, mapReply, init. Comments suggest that "init" can be used
# for re-initialisation, although the command is undocumented.
# - Not exported, probably should be upper-case initial letter as part
| > > > | 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 |
= # LITERAL: Equal sign
([!\u0023-+\u002D-:<-\u005B\u005D-~]*) # Match the value
(?:
\s* ; \s* # LITERAL: semicolon
([^\u0000]+) # Match the options
)?
}
variable TmpSockCounter 0
variable ThreadCounter 0
namespace export geturl config reset wait formatQuery quoteString
namespace export register unregister registerError
# - Useful, but not exported: data, size, status, code, cleanup, error,
# meta, ncode, mapReply, init. Comments suggest that "init" can be used
# for re-initialisation, although the command is undocumented.
# - Not exported, probably should be upper-case initial letter as part
|
| ︙ | ︙ | |||
219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 |
set pat ^-(?:[join $options |])$
if {[llength $args] == 1} {
set flag [lindex $args 0]
if {![regexp -- $pat $flag]} {
return -code error "Unknown option $flag, must be: $usage"
}
return $http($flag)
} else {
foreach {flag value} $args {
if {![regexp -- $pat $flag]} {
return -code error "Unknown option $flag, must be: $usage"
}
set http($flag) $value
}
}
}
# http::Finish --
#
# Clean up the socket and eval close time callbacks
#
| > > > > > > > | 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 |
set pat ^-(?:[join $options |])$
if {[llength $args] == 1} {
set flag [lindex $args 0]
if {![regexp -- $pat $flag]} {
return -code error "Unknown option $flag, must be: $usage"
}
return $http($flag)
} elseif {[llength $args] % 2} {
return -code error "If more than one argument is supplied, the\
number of arguments must be even"
} else {
foreach {flag value} $args {
if {![regexp -- $pat $flag]} {
return -code error "Unknown option $flag, must be: $usage"
}
if {($flag eq {-threadlevel}) && ($value ni {0 1 2})} {
return -code error {Option -threadlevel must be 0, 1 or 2}
}
set http($flag) $value
}
return
}
}
# http::Finish --
#
# Clean up the socket and eval close time callbacks
#
|
| ︙ | ︙ | |||
250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 |
proc http::Finish {token {errormsg ""} {skipCB 0}} {
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketClosing
variable socketPlayCmd
variable $token
upvar 0 $token state
global errorInfo errorCode
set closeQueue 0
if {$errormsg ne ""} {
set state(error) [list $errormsg $errorInfo $errorCode]
set state(status) "error"
}
| > > | | > > | > > > > > > | | < | > | < < < | | < < < | < < < | | < > | | > > > > > > > > > > > > > | > | | > > > > > | | 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 364 365 366 367 |
proc http::Finish {token {errormsg ""} {skipCB 0}} {
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketPhQueue
variable socketClosing
variable socketPlayCmd
variable socketCoEvent
variable $token
upvar 0 $token state
global errorInfo errorCode
set closeQueue 0
if {$errormsg ne ""} {
set state(error) [list $errormsg $errorInfo $errorCode]
set state(status) "error"
}
if {[info commands ${token}--EventCoroutine] ne {}} {
rename ${token}--EventCoroutine {}
}
if {[info commands ${token}--SocketCoroutine] ne {}} {
rename ${token}--SocketCoroutine {}
}
if {[info exists state(socketcoro)]} {
Log $token Cancel socket after-idle event (Finish)
after cancel $state(socketcoro)
unset state(socketcoro)
}
# Is this an upgrade request/response?
set upgradeResponse \
[expr { [info exists state(upgradeRequest)]
&& $state(upgradeRequest)
&& [info exists state(http)]
&& ([ncode $token] eq {101})
&& [info exists state(connection)]
&& ("upgrade" in $state(connection))
&& [info exists state(upgrade)]
&& ("" ne $state(upgrade))
}]
if { ($state(status) eq "timeout")
|| ($state(status) eq "error")
|| ($state(status) eq "eof")
} {
set closeQueue 1
set connId $state(socketinfo)
if {[info exists state(sock)]} {
set sock $state(sock)
CloseSocket $state(sock) $token
} else {
# When opening the socket and calling http::reset
# immediately, the socket may not yet exist.
# Test http-4.11 may come here.
}
if {$state(tid) ne {}} {
# When opening the socket in a thread, and calling http::reset
# immediately, the thread may still exist.
# Test http-4.11 may come here.
thread::release $state(tid)
set state(tid) {}
} else {
}
} elseif {$upgradeResponse} {
# Special handling for an upgrade request/response.
# - geturl ensures that this is not a "persistent" socket used for
# multiple HTTP requests, so a call to KeepSocket is not needed.
# - Leave socket open, so a call to CloseSocket is not needed either.
# - Remove fileevent bindings. The caller will set its own bindings.
# - THE CALLER MUST PROCESS THE UPGRADED SOCKET IN THE CALLBACK COMMAND
# PASSED TO http::geturl AS -command callback.
catch {fileevent $state(sock) readable {}}
catch {fileevent $state(sock) writable {}}
} elseif {
([info exists state(-keepalive)] && !$state(-keepalive))
|| ([info exists state(connection)] && ("close" in $state(connection)))
} {
set closeQueue 1
set connId $state(socketinfo)
if {[info exists state(sock)]} {
set sock $state(sock)
CloseSocket $state(sock) $token
} else {
# When opening the socket and calling http::reset
# immediately, the socket may not yet exist.
# Test http-4.11 may come here.
}
} elseif {
([info exists state(-keepalive)] && $state(-keepalive))
&& ([info exists state(connection)] && ("close" ni $state(connection)))
} {
KeepSocket $token
}
if {[info exists state(after)]} {
after cancel $state(after)
unset state(after)
}
|
| ︙ | ︙ | |||
337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 |
}
if { $closeQueue
&& [info exists socketMapping($connId)]
&& ($socketMapping($connId) eq $sock)
} {
http::CloseQueuedQueries $connId $token
}
}
# http::KeepSocket -
#
# Keep a socket in the persistent sockets table and connect it to its next
# queued task if possible. Otherwise leave it idle and ready for its next
# use.
#
| > > | > > | 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 |
}
if { $closeQueue
&& [info exists socketMapping($connId)]
&& ($socketMapping($connId) eq $sock)
} {
http::CloseQueuedQueries $connId $token
# This calls Unset. Other cases do not need the call.
}
return
}
# http::KeepSocket -
#
# Keep a socket in the persistent sockets table and connect it to its next
# queued task if possible. Otherwise leave it idle and ready for its next
# use.
#
# If $socketClosing(*), then ("close" in $state(connection)) and therefore
# this command will not be called by Finish.
#
# Arguments:
# token Connection token.
proc http::KeepSocket {token} {
variable http
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketPhQueue
variable socketClosing
variable socketPlayCmd
variable socketCoEvent
variable $token
upvar 0 $token state
set tk [namespace tail $token]
# Keep this socket open for another request ("Keep-Alive").
# React if the server half-closes the socket.
|
| ︙ | ︙ | |||
395 396 397 398 399 400 401 |
&& [info exists socketRdQueue($connId)]
&& [llength $socketRdQueue($connId)]
} {
# The usual case for pipelined responses - if another response is
# queued, arrange to read it.
set token3 [lindex $socketRdQueue($connId) 0]
set socketRdQueue($connId) [lrange $socketRdQueue($connId) 1 end]
| < < < | 437 438 439 440 441 442 443 444 445 446 447 448 449 450 |
&& [info exists socketRdQueue($connId)]
&& [llength $socketRdQueue($connId)]
} {
# The usual case for pipelined responses - if another response is
# queued, arrange to read it.
set token3 [lindex $socketRdQueue($connId) 0]
set socketRdQueue($connId) [lrange $socketRdQueue($connId) 1 end]
#Log pipelined, GRANT read access to $token3 in KeepSocket
set socketRdState($connId) $token3
ReceiveResponse $token3
# Other pipelined cases.
# - The test above ensures that, for the pipelined cases in the two
|
| ︙ | ︙ | |||
436 437 438 439 440 441 442 | # "pending" write token is in front of the rest of the write # queue. # - The write state is not Wready and therefore appears to be busy, # but because it is "pending" we know that it is reserved for the # first item in the write queue, a non-pipelined request that is # waiting for the read queue to empty. That has now happened: so # give that request read and write access. | < | | 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 |
# "pending" write token is in front of the rest of the write
# queue.
# - The write state is not Wready and therefore appears to be busy,
# but because it is "pending" we know that it is reserved for the
# first item in the write queue, a non-pipelined request that is
# waiting for the read queue to empty. That has now happened: so
# give that request read and write access.
set conn [set ${token3}(connArgs)]
#Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
set socketRdState($connId) $token3
set socketWrState($connId) $token3
set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
# Connect does its own fconfigure.
fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
#Log ---- $state(sock) << conn to $token3 for HTTP request (c)
|
| ︙ | ︙ | |||
481 482 483 484 485 486 487 | # Tests: # - In this case the read state (tested above) is Rready and the # write state (tested here) is Wready - there is no "pending" # request. # Code: # - The code is the same as the code below for the nonpipelined # case with a queued request. | < | | < | > | 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 561 562 563 564 565 566 567 568 569 570 571 572 573 |
# Tests:
# - In this case the read state (tested above) is Rready and the
# write state (tested here) is Wready - there is no "pending"
# request.
# Code:
# - The code is the same as the code below for the nonpipelined
# case with a queued request.
set conn [set ${token3}(connArgs)]
#Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
set socketRdState($connId) $token3
set socketWrState($connId) $token3
set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
# Connect does its own fconfigure.
fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
#Log ---- $state(sock) << conn to $token3 for HTTP request (c)
} elseif {
(!$state(-pipeline))
&& [info exists socketWrQueue($connId)]
&& [llength $socketWrQueue($connId)]
&& ("close" ni $state(connection))
} {
# If not pipelined, (socketRdState eq Rready) tells us that we are
# ready for the next write - there is no need to check
# socketWrState. Write the next request, if one is waiting.
# If the next request is pipelined, it receives premature read
# access to the socket. This is not a problem.
set token3 [lindex $socketWrQueue($connId) 0]
set conn [set ${token3}(connArgs)]
#Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
set socketRdState($connId) $token3
set socketWrState($connId) $token3
set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
# Connect does its own fconfigure.
fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
#Log ---- $state(sock) << conn to $token3 for HTTP request (d)
} elseif {(!$state(-pipeline))} {
set socketWrState($connId) Wready
# Rready and Wready and idle: nothing to do.
}
} else {
CloseSocket $state(sock) $token
# There is no socketMapping($state(socketinfo)), so it does not matter
# that CloseQueuedQueries is not called.
}
return
}
# http::CheckEof -
#
# Read from a socket and close it if eof.
# The command is bound to "fileevent readable" on an idle socket, and
# "eof" is the only event that should trigger the binding, occurring when
|
| ︙ | ︙ | |||
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 |
if {[catch {eof $sock} res] || $res} {
# The server has half-closed the socket.
# If a new write has started, its transaction will fail and
# will then be error-handled.
CloseSocket $sock
}
}
# http::CloseSocket -
#
# Close a socket and remove it from the persistent sockets table. If
# possible an http token is included here but when we are called from a
# fileevent on remote closure we need to find the correct entry - hence
# the "else" block of the first "if" command.
proc http::CloseSocket {s {token {}}} {
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketClosing
variable socketPlayCmd
set tk [namespace tail $token]
catch {fileevent $s readable {}}
set connId {}
if {$token ne ""} {
variable $token
| > > > | 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 611 612 613 614 615 616 617 618 |
if {[catch {eof $sock} res] || $res} {
# The server has half-closed the socket.
# If a new write has started, its transaction will fail and
# will then be error-handled.
CloseSocket $sock
}
return
}
# http::CloseSocket -
#
# Close a socket and remove it from the persistent sockets table. If
# possible an http token is included here but when we are called from a
# fileevent on remote closure we need to find the correct entry - hence
# the "else" block of the first "if" command.
proc http::CloseSocket {s {token {}}} {
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketPhQueue
variable socketClosing
variable socketPlayCmd
variable socketCoEvent
set tk [namespace tail $token]
catch {fileevent $s readable {}}
set connId {}
if {$token ne ""} {
variable $token
|
| ︙ | ︙ | |||
591 592 593 594 595 596 597 598 599 600 601 602 603 604 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 |
if { ($connId ne {})
&& [info exists socketMapping($connId)]
&& ($socketMapping($connId) eq $s)
} {
Log "Closing connection $connId (sock $socketMapping($connId))"
if {[catch {close $socketMapping($connId)} err]} {
Log "Error closing connection: $err"
}
if {$token eq {}} {
# Cases with a non-empty token are handled by Finish, so the tokens
# are finished in connection order.
http::CloseQueuedQueries $connId
}
} else {
Log "Closing socket $s (no connection info)"
if {[catch {close $s} err]} {
Log "Error closing socket: $err"
}
}
}
# http::CloseQueuedQueries
#
# connId - identifier "domain:port" for the connection
# token - (optional) used only for logging
#
# Called from http::CloseSocket and http::Finish, after a connection is closed,
# to clear the read and write queues if this has not already been done.
proc http::CloseQueuedQueries {connId {token {}}} {
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketClosing
variable socketPlayCmd
if {![info exists socketMapping($connId)]} {
# Command has already been called.
# Don't come here again - especially recursively.
return
}
# Used only for logging.
| > > > > > > > | 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 |
if { ($connId ne {})
&& [info exists socketMapping($connId)]
&& ($socketMapping($connId) eq $s)
} {
Log "Closing connection $connId (sock $socketMapping($connId))"
if {[catch {close $socketMapping($connId)} err]} {
Log "Error closing connection: $err"
} else {
}
if {$token eq {}} {
# Cases with a non-empty token are handled by Finish, so the tokens
# are finished in connection order.
http::CloseQueuedQueries $connId
} else {
}
} else {
Log "Closing socket $s (no connection info)"
if {[catch {close $s} err]} {
Log "Error closing socket: $err"
} else {
}
}
return
}
# http::CloseQueuedQueries
#
# connId - identifier "domain:port" for the connection
# token - (optional) used only for logging
#
# Called from http::CloseSocket and http::Finish, after a connection is closed,
# to clear the read and write queues if this has not already been done.
proc http::CloseQueuedQueries {connId {token {}}} {
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketPhQueue
variable socketClosing
variable socketPlayCmd
variable socketCoEvent
##Log CloseQueuedQueries $connId
if {![info exists socketMapping($connId)]} {
# Command has already been called.
# Don't come here again - especially recursively.
return
}
# Used only for logging.
|
| ︙ | ︙ | |||
645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 |
# Before unsetting, there is some unfinished business.
# - If the server sent "Connection: close", we have stored the command
# for retrying any queued requests in socketPlayCmd, so copy that
# value for execution below. socketClosing(*) was also set.
# - Also clear the queues to prevent calls to Finish that would set the
# state for the requests that will be retried to "finished with error
# status".
set unfinished $socketPlayCmd($connId)
set socketRdQueue($connId) {}
set socketWrQueue($connId) {}
} else {
set unfinished {}
}
Unset $connId
if {$unfinished ne {}} {
Log ^R$tk Any unfinished transactions (excluding $token) failed \
| > | > > > > > | 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 |
# Before unsetting, there is some unfinished business.
# - If the server sent "Connection: close", we have stored the command
# for retrying any queued requests in socketPlayCmd, so copy that
# value for execution below. socketClosing(*) was also set.
# - Also clear the queues to prevent calls to Finish that would set the
# state for the requests that will be retried to "finished with error
# status".
# - At this stage socketPhQueue is empty.
set unfinished $socketPlayCmd($connId)
set socketRdQueue($connId) {}
set socketWrQueue($connId) {}
} else {
set unfinished {}
}
Unset $connId
if {$unfinished ne {}} {
Log ^R$tk Any unfinished transactions (excluding $token) failed \
- token $token - unfinished $unfinished
{*}$unfinished
# Calls ReplayIfClose.
}
return
}
# http::Unset
#
# The trace on "unset socketRdState(*)" will call CancelReadPipeline
# and cancel any queued responses.
# The trace on "unset socketWrState(*)" will call CancelWritePipeline
# and cancel any queued requests.
proc http::Unset {connId} {
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketPhQueue
variable socketClosing
variable socketPlayCmd
variable socketCoEvent
unset socketMapping($connId)
unset socketRdState($connId)
unset socketWrState($connId)
unset -nocomplain socketRdQueue($connId)
unset -nocomplain socketWrQueue($connId)
unset -nocomplain socketClosing($connId)
unset -nocomplain socketPlayCmd($connId)
return
}
# http::reset --
#
# See documentation for details.
#
# Arguments:
|
| ︙ | ︙ | |||
709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 |
catch {fileevent $state(sock) writable {}}
Finish $token
if {[info exists state(error)]} {
set errorlist $state(error)
unset state
eval ::error $errorlist
}
}
# http::geturl --
#
# Establishes a connection to a remote url via http.
#
# Arguments:
# url The http URL to goget.
# args Option value pairs. Valid options include:
# -blocksize, -validate, -headers, -timeout
# Results:
# Returns a token for this connection. This token is the name of an
# array that the caller should unset to garbage collect the state.
proc http::geturl {url args} {
variable http
variable urlTypes
variable defaultCharset
variable defaultKeepalive
variable strict
# Initialize the state variable, an array. We'll return the name of this
# array as the token for the transaction.
if {![info exists http(uid)]} {
set http(uid) 0
}
set token [namespace current]::[incr http(uid)]
##Log Starting http::geturl - token $token
variable $token
upvar 0 $token state
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 762 763 764 765 766 767 768 769 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 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 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 |
catch {fileevent $state(sock) writable {}}
Finish $token
if {[info exists state(error)]} {
set errorlist $state(error)
unset state
eval ::error $errorlist
}
return
}
# http::geturl --
#
# Establishes a connection to a remote url via http.
#
# Arguments:
# url The http URL to goget.
# args Option value pairs. Valid options include:
# -blocksize, -validate, -headers, -timeout
# Results:
# Returns a token for this connection. This token is the name of an
# array that the caller should unset to garbage collect the state.
proc http::geturl {url args} {
variable urlTypes
# The value is set in the namespace header of this file. If the file has
# not been modified the value is "::http::socket".
set socketCmd [lindex $urlTypes(http) 1]
# - If ::tls::socketCmd has its default value "::socket", change it to the
# new value $socketCmd.
# - If the old value is different, then it has been modified either by the
# script or by the Tcl installation, and replaced by a new command. The
# script or installation that modified ::tls::socketCmd is also
# responsible for integrating ::http::socket into its own "new" command,
# if it wishes to do so.
if {[info exists ::tls::socketCmd] && ($::tls::socketCmd eq {::socket})} {
set ::tls::socketCmd $socketCmd
}
set token [CreateToken $url {*}$args]
variable $token
upvar 0 $token state
AsyncTransaction $token
# --------------------------------------------------------------------------
# Synchronous Call to http::geturl
# --------------------------------------------------------------------------
# - If the call to http::geturl is asynchronous, it is now complete (apart
# from delivering the return value).
# - If the call to http::geturl is synchronous, the command must now wait
# for the HTTP transaction to be completed. The call to http::wait uses
# vwait, which may be inappropriate if the caller makes other HTTP
# requests in the background.
# --------------------------------------------------------------------------
if {![info exists state(-command)]} {
# geturl does EVERYTHING asynchronously, so if the user
# calls it synchronously, we just do a wait here.
http::wait $token
if {![info exists state]} {
# If we timed out then Finish has been called and the users
# command callback may have cleaned up the token. If so we end up
# here with nothing left to do.
return $token
} elseif {$state(status) eq "error"} {
# Something went wrong while trying to establish the connection.
# Clean up after events and such, but DON'T call the command
# callback (if available) because we're going to throw an
# exception from here instead.
set err [lindex $state(error) 0]
cleanup $token
return -code error $err
}
}
return $token
}
# ------------------------------------------------------------------------------
# Proc http::CreateToken
# ------------------------------------------------------------------------------
# Command to convert arguments into an initialised request token.
# The return value is the variable name of the token.
#
# Other effects:
# - Sets ::http::http(usingThread) if not already done
# - Sets ::http::http(uid) if not already done
# - Increments ::http::http(uid)
# - May increment ::http::TmpSockCounter
# - Alters ::http::socketPlayCmd, ::http::socketWrQueue if a -keepalive 1
# request is appended to the queue of a persistent socket that is already
# scheduled to close.
# This also sets state(alreadyQueued) to 1.
# - Alters ::http::socketPhQueue if a -keepalive 1 request is appended to the
# queue of a persistent socket that has not yet been created (and is therefore
# represented by a placeholder).
# This also sets state(ReusingPlaceholder) to 1.
# ------------------------------------------------------------------------------
proc http::CreateToken {url args} {
variable http
variable urlTypes
variable defaultCharset
variable defaultKeepalive
variable strict
variable TmpSockCounter
# Initialize the state variable, an array. We'll return the name of this
# array as the token for the transaction.
if {![info exists http(usingThread)]} {
set http(usingThread) 0
}
if {![info exists http(uid)]} {
set http(uid) 0
}
set token [namespace current]::[incr http(uid)]
##Log Starting http::geturl - token $token
variable $token
upvar 0 $token state
|
| ︙ | ︙ | |||
770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 |
querylength 0
queryoffset 0
type text/html
body {}
status ""
http ""
connection keep-alive
}
set state(-keepalive) $defaultKeepalive
set state(-strict) $strict
# These flags have their types verified [Bug 811170]
array set type {
-binary boolean
-blocksize integer
-queryblocksize integer
-strict boolean
-timeout integer
-validate boolean
| > | | | > > > > > | 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 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 |
querylength 0
queryoffset 0
type text/html
body {}
status ""
http ""
connection keep-alive
tid {}
}
set state(-keepalive) $defaultKeepalive
set state(-strict) $strict
# These flags have their types verified [Bug 811170]
array set type {
-binary boolean
-blocksize integer
-queryblocksize integer
-strict boolean
-timeout integer
-validate boolean
-headers list
}
set state(charset) $defaultCharset
set options {
-binary -blocksize -channel -command -handler -headers -keepalive
-method -myaddr -progress -protocol -query -queryblocksize
-querychannel -queryprogress -strict -timeout -type -validate
}
set usage [join [lsort $options] ", "]
set options [string map {- ""} $options]
set pat ^-(?:[join $options |])$
foreach {flag value} $args {
if {[regexp -- $pat $flag]} {
# Validate numbers
if { [info exists type($flag)]
&& (![string is $type($flag) -strict $value])
} {
unset $token
return -code error \
"Bad value for $flag ($value), must be $type($flag)"
}
if {($flag eq "-headers") && ([llength $value] % 2 != 0)} {
unset $token
return -code error "Bad value for $flag ($value), number\
of list elements must be even"
}
set state($flag) $value
} else {
unset $token
return -code error "Unknown option $flag, can be: $usage"
}
}
|
| ︙ | ︙ | |||
964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 |
if {$port eq ""} {
set port $defport
}
if {![catch {$http(-proxyfilter) $host} proxy]} {
set phost [lindex $proxy 0]
set pport [lindex $proxy 1]
}
# OK, now reassemble into a full URL
set url ${proto}://
if {$user ne ""} {
append url $user
append url @
}
append url $host
if {$port != $defport} {
append url : $port
}
append url $srvurl
| > > > | < < < < < < < < < < < | | | | > | > | | 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 |
if {$port eq ""} {
set port $defport
}
if {![catch {$http(-proxyfilter) $host} proxy]} {
set phost [lindex $proxy 0]
set pport [lindex $proxy 1]
} else {
set phost {}
set pport {}
}
# OK, now reassemble into a full URL
set url ${proto}://
if {$user ne ""} {
append url $user
append url @
}
append url $host
if {$port != $defport} {
append url : $port
}
append url $srvurl
# Don't append the fragment! RFC 7230 Sec 5.1
set state(url) $url
# Proxy connections aren't shared among different hosts.
set state(socketinfo) $host:$port
# Save the accept types at this point to prevent a race condition. [Bug
# c11a51c482]
set state(accept-types) $http(-accept)
# Check whether this is an Upgrade request.
set connectionValues [SplitCommaSeparatedFieldValue \
[GetFieldValue $state(-headers) Connection]]
set connectionValues [string tolower $connectionValues]
set upgradeValues [SplitCommaSeparatedFieldValue \
[GetFieldValue $state(-headers) Upgrade]]
set state(upgradeRequest) [expr { "upgrade" in $connectionValues
&& [llength $upgradeValues] >= 1}]
if {$isQuery || $isQueryChannel} {
# It's a POST.
# A client wishing to send a non-idempotent request SHOULD wait to send
# that request until it has received the response status for the
# previous request.
if {$http(-postfresh)} {
|
| ︙ | ︙ | |||
1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 |
# RFC 7320 A.1 - HTTP/1.0 Keep-Alive is problematic. We do not support it.
if {$state(-protocol) eq "1.0"} {
set state(connection) close
set state(-keepalive) 0
}
# See if we are supposed to use a previously opened channel.
# - In principle, ANY call to http::geturl could use a previously opened
# channel if it is available - the "Connection: keep-alive" header is a
# request to leave the channel open AFTER completion of this call.
# - In fact, we try to use an existing channel only if -keepalive 1 -- this
# means that at most one channel is left open for each value of
# $state(socketinfo). This property simplifies the mapping of open
# channels.
set reusing 0
| > > > > > > > > > > > > > > > > > > > | > > > | 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 |
# RFC 7320 A.1 - HTTP/1.0 Keep-Alive is problematic. We do not support it.
if {$state(-protocol) eq "1.0"} {
set state(connection) close
set state(-keepalive) 0
}
# If we are using the proxy, we must pass in the full URL that includes
# the server name.
if {$phost ne ""} {
set srvurl $url
set targetAddr [list $phost $pport]
} else {
set targetAddr [list $host $port]
}
set sockopts [list -async]
# Pass -myaddr directly to the socket command
if {[info exists state(-myaddr)]} {
lappend sockopts -myaddr $state(-myaddr)
}
set state(connArgs) [list $proto $phost $srvurl]
set state(openCmd) [list {*}$defcmd {*}$sockopts {*}$targetAddr]
# See if we are supposed to use a previously opened channel.
# - In principle, ANY call to http::geturl could use a previously opened
# channel if it is available - the "Connection: keep-alive" header is a
# request to leave the channel open AFTER completion of this call.
# - In fact, we try to use an existing channel only if -keepalive 1 -- this
# means that at most one channel is left open for each value of
# $state(socketinfo). This property simplifies the mapping of open
# channels.
set reusing 0
set state(alreadyQueued) 0
set state(ReusingPlaceholder) 0
if {$state(-keepalive)} {
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketPhQueue
variable socketClosing
variable socketPlayCmd
variable socketCoEvent
if {[info exists socketMapping($state(socketinfo))]} {
# - If the connection is idle, it has a "fileevent readable" binding
# to http::CheckEof, in case the server times out and half-closes
# the socket (http::CheckEof closes the other half).
# - We leave this binding in place until just before the last
# puts+flush in http::Connected (GET/HEAD) or http::Write (POST),
|
| ︙ | ︙ | |||
1082 1083 1084 1085 1086 1087 1088 | # Since we have only one persistent socket per server, and the # old socket is not yet dead, add the request to the write queue # of the dying socket, which will be replayed by ReplayIfClose. # Also add it to socketWrQueue(*) which is used only if an error # causes a call to Finish. set reusing 1 set sock $socketMapping($state(socketinfo)) | | | > > > | > > > | | | | > > > | > | > < < < < < < < < < < < < < > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | > | > > > > > > > > > > > | | > | | > | > > > > > > > | | < | > > < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > | > | | | | | > > > > > > > > > > > > | > | < < > | | | > | | > > | | | > | > > > | < > | > > | > | > > | > | > > > > > > > > > > > > > > | | > > | > > | < | < < > > > | < < < < | | > > | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 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 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 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 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 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 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 |
# Since we have only one persistent socket per server, and the
# old socket is not yet dead, add the request to the write queue
# of the dying socket, which will be replayed by ReplayIfClose.
# Also add it to socketWrQueue(*) which is used only if an error
# causes a call to Finish.
set reusing 1
set sock $socketMapping($state(socketinfo))
Log "reusing closing socket $sock for $state(socketinfo) - token $token"
set state(alreadyQueued) 1
lassign $socketPlayCmd($state(socketinfo)) com0 com1 com2 com3
lappend com3 $token
set socketPlayCmd($state(socketinfo)) [list $com0 $com1 $com2 $com3]
lappend socketWrQueue($state(socketinfo)) $token
##Log socketPlayCmd($state(socketinfo)) is $socketPlayCmd($state(socketinfo))
##Log socketWrQueue($state(socketinfo)) is $socketWrQueue($state(socketinfo))
} elseif {
[catch {fconfigure $socketMapping($state(socketinfo))}]
&& (![SockIsPlaceHolder $socketMapping($state(socketinfo))])
} {
###Log "Socket $socketMapping($state(socketinfo)) for $state(socketinfo)"
# FIXME Is it still possible for this code to be executed? If
# so, this could be another place to call TestForReplay,
# rather than discarding the queued transactions.
Log "WARNING: socket for $state(socketinfo) was closed\
- token $token"
Log "WARNING - if testing, pay special attention to this\
case (GH) which is seldom executed - token $token"
# This will call CancelReadPipeline, CancelWritePipeline, and
# cancel any queued requests, responses.
Unset $state(socketinfo)
} else {
# Use the persistent socket.
# - The socket may not be ready to write: an earlier request might
# still be still writing (in the pipelined case) or
# writing/reading (in the nonpipeline case). This possibility
# is handled by socketWrQueue later in this command.
# - The socket may not yet exist, and be defined with a placeholder.
set reusing 1
set sock $socketMapping($state(socketinfo))
if {[SockIsPlaceHolder $sock]} {
set state(ReusingPlaceholder) 1
lappend socketPhQueue($sock) $token
} else {
}
Log "reusing open socket $sock for $state(socketinfo) - token $token"
}
# Do not automatically close the connection socket.
set state(connection) keep-alive
}
}
set state(reusing) $reusing
unset reusing
if {![info exists sock]} {
# N.B. At this point ([info exists sock] == $state(reusing)).
# This will no longer be true after we set a value of sock here.
# Give the socket a placeholder name.
set sock HTTP_PLACEHOLDER_[incr TmpSockCounter]
}
set state(sock) $sock
if {$state(reusing)} {
# Define these for use (only) by http::ReplayIfDead if the persistent
# connection has died.
set state(tmpConnArgs) $state(connArgs)
set state(tmpState) [array get state]
set state(tmpOpenCmd) $state(openCmd)
}
return $token
}
# ------------------------------------------------------------------------------
# Proc ::http::SockIsPlaceHolder
# ------------------------------------------------------------------------------
# Command to return 0 if the argument is a genuine socket handle, or 1 if is a
# placeholder value generated by geturl or ReplayCore before the real socket is
# created.
#
# Arguments:
# sock - either a valid socket handle or a placeholder value
#
# Return Value: 0 or 1
# ------------------------------------------------------------------------------
proc http::SockIsPlaceHolder {sock} {
expr {[string range $sock 0 16] eq {HTTP_PLACEHOLDER_}}
}
# ------------------------------------------------------------------------------
# state(reusing)
# ------------------------------------------------------------------------------
# - state(reusing) is set by geturl, ReplayCore
# - state(reusing) is used by geturl, AsyncTransaction, OpenSocket,
# ConfigureNewSocket, and ScheduleRequest when creating and configuring the
# connection.
# - state(reusing) is used by Connect, Connected, Event x 2 when deciding
# whether to call TestForReplay.
# - Other places where state(reusing) is used:
# - Connected - if reusing and not pipelined, start the state(-timeout)
# timeout (when writing).
# - DoneRequest - if reusing and pipelined, send the next pipelined write
# - Event - if reusing and pipelined, start the state(-timeout)
# timeout (when reading).
# - Event - if (not reusing) and pipelined, send the next pipelined
# write.
# ------------------------------------------------------------------------------
# ------------------------------------------------------------------------------
# Proc http::AsyncTransaction
# ------------------------------------------------------------------------------
# This command is called by geturl and ReplayCore to prepare the HTTP
# transaction prescribed by a suitably prepared token.
#
# Arguments:
# token - connection token (name of an array)
#
# Return Value: none
# ------------------------------------------------------------------------------
proc http::AsyncTransaction {token} {
variable $token
upvar 0 $token state
set tk [namespace tail $token]
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketPhQueue
variable socketClosing
variable socketPlayCmd
variable socketCoEvent
set sock $state(sock)
# See comments above re the start of this timeout in other cases.
if {(!$state(reusing)) && ($state(-timeout) > 0)} {
set state(after) [after $state(-timeout) \
[list http::reset $token timeout]]
}
if { $state(-keepalive)
&& (![info exists socketMapping($state(socketinfo))])
} {
# This code is executed only for the first -keepalive request on a
# socket. It makes the socket persistent.
##Log " PreparePersistentConnection" $token -- $sock -- DO
set DoLater [PreparePersistentConnection $token]
} else {
##Log " PreparePersistentConnection" $token -- $sock -- SKIP
set DoLater {-traceread 0 -tracewrite 0}
}
if {$state(ReusingPlaceholder)} {
# - This request was added to the socketPhQueue of a persistent
# connection.
# - But the connection has not yet been created and is a placeholder;
# - And the placeholder was created by an earlier request.
# - When that earlier request calls OpenSocket, its placeholder is
# replaced with a true socket, and it then executes the equivalent of
# OpenSocket for any subsequent requests that have
# $state(ReusingPlaceholder).
Log >J$tk after idle coro NO - ReusingPlaceholder
} elseif {$state(alreadyQueued)} {
# - This request was added to the socketWrQueue and socketPlayCmd
# of a persistent connection that will close at the end of its current
# read operation.
Log >J$tk after idle coro NO - alreadyQueued
} else {
Log >J$tk after idle coro YES
set CoroName ${token}--SocketCoroutine
set cancel [after idle [list coroutine $CoroName ::http::OpenSocket \
$token $DoLater]]
dict set socketCoEvent($state(socketinfo)) $token $cancel
set state(socketcoro) $cancel
}
return
}
# ------------------------------------------------------------------------------
# Proc http::PreparePersistentConnection
# ------------------------------------------------------------------------------
# This command is called by AsyncTransaction to initialise a "persistent
# connection" based upon a socket placeholder. It is called the first time the
# socket is associated with a "-keepalive" request.
#
# Arguments:
# token - connection token (name of an array)
#
# Return Value: - DoLater, a dictionary of boolean values listing unfinished
# tasks; to be passed to ConfigureNewSocket via OpenSocket.
# ------------------------------------------------------------------------------
proc http::PreparePersistentConnection {token} {
variable $token
upvar 0 $token state
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketPhQueue
variable socketClosing
variable socketPlayCmd
variable socketCoEvent
set DoLater {-traceread 0 -tracewrite 0}
set socketMapping($state(socketinfo)) $state(sock)
if {![info exists socketRdState($state(socketinfo))]} {
set socketRdState($state(socketinfo)) {}
# set varName ::http::socketRdState($state(socketinfo))
# trace add variable $varName unset ::http::CancelReadPipeline
dict set DoLater -traceread 1
}
if {![info exists socketWrState($state(socketinfo))]} {
set socketWrState($state(socketinfo)) {}
# set varName ::http::socketWrState($state(socketinfo))
# trace add variable $varName unset ::http::CancelWritePipeline
dict set DoLater -tracewrite 1
}
if {$state(-pipeline)} {
#Log new, init for pipelined, GRANT write access to $token in geturl
# Also grant premature read access to the socket. This is OK.
set socketRdState($state(socketinfo)) $token
set socketWrState($state(socketinfo)) $token
} else {
# socketWrState is not used by this non-pipelined transaction.
# We cannot leave it as "Wready" because the next call to
# http::geturl with a pipelined transaction would conclude that the
# socket is available for writing.
#Log new, init for nonpipeline, GRANT r/w access to $token in geturl
set socketRdState($state(socketinfo)) $token
set socketWrState($state(socketinfo)) $token
}
set socketRdQueue($state(socketinfo)) {}
set socketWrQueue($state(socketinfo)) {}
set socketPhQueue($state(socketinfo)) {}
set socketClosing($state(socketinfo)) 0
set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}}
set socketCoEvent($state(socketinfo)) {}
return $DoLater
}
# ------------------------------------------------------------------------------
# Proc ::http::OpenSocket
# ------------------------------------------------------------------------------
# This command is called as a coroutine idletask to start the asynchronous HTTP
# transaction in most cases. For the exceptions, see the calling code in
# command AsyncTransaction.
#
# Arguments:
# token - connection token (name of an array)
# DoLater - dictionary of boolean values listing unfinished tasks
#
# Return Value: none
# ------------------------------------------------------------------------------
proc http::OpenSocket {token DoLater} {
variable $token
upvar 0 $token state
set tk [namespace tail $token]
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketPhQueue
variable socketClosing
variable socketPlayCmd
variable socketCoEvent
Log >K$tk Start OpenSocket coroutine
if {![info exists state(-keepalive)]} {
# The request has already been cancelled by the calling script.
return
}
set sockOld $state(sock)
dict unset socketCoEvent($state(socketinfo)) $token
unset -nocomplain state(socketcoro)
set reusing $state(reusing)
if {$reusing} {
# If ($reusing) is true, then we do not need to create a new socket,
# even if $sockOld is only a placeholder for a socket.
set sock $sockOld
} else {
# set sock in the [catch] below.
set pre [clock milliseconds]
##Log pre socket opened, - token $token
##Log $state(openCmd) - token $token
if {[catch {eval $state(openCmd)} sock errdict]} {
# ERROR CASE
# Something went wrong while trying to establish the connection.
# Tidy up after events and such, but DON'T call the command
# callback (if available).
# - When this was inline code in http::geturl, it threw an exception
# from here instead.
# - Now that this code is called from geturl as an idletask and not
# as inline code, it is inappropriate to run cleanup or throw an
# exception. Instead do a normal return, and let Finish report
# the error using token/state and the -command callback.
# Finish also undoes PreparePersistentConnection.
set state(sock) NONE
set ::errorInfo [dict get $errdict -errorinfo]
set ::errorCode [dict get $errdict -errorcode]
Finish $token $sock
# cleanup $token
return
} else {
# Normal return from $state(openCmd) always returns a valid socket.
# Initialisation of a new socket.
##Log post socket opened, - token $token
##Log socket opened, now fconfigure - token $token
set state(sock) $sock
set delay [expr {[clock milliseconds] - $pre}]
if {$delay > 3000} {
Log socket delay $delay - token $token
}
fconfigure $sock -translation {auto crlf} \
-buffersize $state(-blocksize)
##Log socket opened, DONE fconfigure - token $token
}
}
Log "Using $sock for $state(socketinfo) - token $token" \
[expr {$state(-keepalive)?"keepalive":""}]
# Code above has set state(sock) $sock
ConfigureNewSocket $token $sockOld $DoLater
##Log Leaving http::OpenSocket coroutine [info coroutine] - token $token
return
}
# ------------------------------------------------------------------------------
# Proc ::http::ConfigureNewSocket
# ------------------------------------------------------------------------------
# Command to initialise a newly-created socket. Called only from OpenSocket.
#
# This command is called by OpenSocket whenever a genuine socket (sockNew) has
# been opened for for use by HTTP. It does two things:
# (1) If $token uses a placeholder socket, this command replaces the placeholder
# socket with the real socket, not only in $token but in all other requests
# that use the same placeholder.
# (2) It calls ScheduleRequest to schedule each request that uses the socket.
#
#
# Value of sockOld/sockNew can be "sock" (genuine socket) or "ph" (placeholder).
# sockNew is ${token}(sock)
# sockOld sockNew CASES
# sock sock (if $reusing, and sockOld is sock)
# ph sock (if (not $reusing), and sockOld is ph)
# ph ph (if $reusing, and sockOld is ph) - not called in this case
# sock ph (cannot occur unless a bug) - not called in this case
# (if (not $reusing), and sockOld is sock) - illogical
#
# Arguments:
# token - connection token (name of an array)
# sockOld - handle or placeholder used for a socket before the call to OpenSocket
# DoLater - dictionary of boolean values listing unfinished tasks
#
# Return Value: none
# ------------------------------------------------------------------------------
proc http::ConfigureNewSocket {token sockOld DoLater} {
variable $token
upvar 0 $token state
set tk [namespace tail $token]
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketPhQueue
variable socketClosing
variable socketPlayCmd
variable socketCoEvent
set reusing $state(reusing)
set sock $state(sock)
##Log " ConfigureNewSocket" $token $sockOld ... -- $sock
if {(!$reusing) && ($sock ne $sockOld)} {
# Replace the placeholder value sockOld with sock.
if { [info exists socketMapping($state(socketinfo))]
&& ($socketMapping($state(socketinfo)) eq $sockOld)
} {
set socketMapping($state(socketinfo)) $sock
##Log set socketMapping($state(socketinfo)) $sock
}
# Now finish any tasks left over from PreparePersistentConnection on
# the connection.
#
# The "unset" traces are fired by init (clears entire arrays), and
# by http::Unset.
# Unset is called by CloseQueuedQueries and (possibly never) by geturl.
#
# CancelReadPipeline, CancelWritePipeline call http::Finish for each
# token.
#
# FIXME If Finish is placeholder-aware, these traces can be set earlier,
# in PreparePersistentConnection.
if {[dict get $DoLater -traceread]} {
set varName ::http::socketRdState($state(socketinfo))
trace add variable $varName unset ::http::CancelReadPipeline
}
if {[dict get $DoLater -tracewrite]} {
set varName ::http::socketWrState($state(socketinfo))
trace add variable $varName unset ::http::CancelWritePipeline
}
}
# Do this in all cases.
ScheduleRequest $token
# Now look at all other tokens that use the placeholder $sockOld.
if { (!$reusing)
&& ($sock ne $sockOld)
&& [info exists socketPhQueue($sockOld)]
} {
##Log " ConfigureNewSocket" $token scheduled, now do $socketPhQueue($sockOld)
foreach tok $socketPhQueue($sockOld) {
# 1. Amend the token's (sock).
##Log set ${tok}(sock) $sock
set ${tok}(sock) $sock
# 2. Schedule the token's HTTP request.
# Every token in socketPhQueue(*) has reusing 1 alreadyQueued 0.
set ${tok}(reusing) 1
set ${tok}(alreadyQueued) 0
ScheduleRequest $tok
}
set socketPhQueue($sockOld) {}
}
##Log " ConfigureNewSocket" $token DONE
return
}
# ------------------------------------------------------------------------------
# The values of array variables socketMapping etc.
# ------------------------------------------------------------------------------
# connId "$host:$port"
# socketMapping($connId) the handle or placeholder for the socket that is used
# for "-keepalive 1" requests to $connId.
# socketRdState($connId) the token that is currently reading from the socket.
# Other values: Rready (ready for next token to read).
# socketWrState($connId) the token that is currently writing to the socket.
# Other values: Wready (ready for next token to write),
# peNding (would be ready for next write, except that
# the integrity of a non-pipelined transaction requires
# waiting until the read(s) in progress are finished).
# socketRdQueue($connId) List of tokens that are queued for reading later.
# socketWrQueue($connId) List of tokens that are queued for writing later.
# socketPhQueue($connId) List of tokens that are queued to use a placeholder
# socket, when the real socket has not yet been created.
# socketClosing($connId) (boolean) true iff a server response header indicates
# that the server will close the connection at the end of
# the current response.
# socketPlayCmd($connId) The command to execute to replay pending and
# part-completed transactions if the socket closes early.
# socketCoEvent($connId) Identifier for the "after idle" event that will launch
# an OpenSocket coroutine to open or re-use a socket.
# ------------------------------------------------------------------------------
# ------------------------------------------------------------------------------
# Using socketWrState(*), socketWrQueue(*), socketRdState(*), socketRdQueue(*)
# ------------------------------------------------------------------------------
# The element socketWrState($connId) has a value which is either the name of
# the token that is permitted to write to the socket, or "Wready" if no
# token is permitted to write.
#
# The code that sets the value to Wready immediately calls
# http::NextPipelinedWrite, which examines socketWrQueue($connId) and
# processes the next request in the queue, if there is one. The value
# Wready is not found when the interpreter is in the event loop unless the
# socket is idle.
#
# The element socketRdState($connId) has a value which is either the name of
# the token that is permitted to read from the socket, or "Rready" if no
# token is permitted to read.
#
# The code that sets the value to Rready then examines
# socketRdQueue($connId) and processes the next request in the queue, if
# there is one. The value Rready is not found when the interpreter is in
# the event loop unless the socket is idle.
# ------------------------------------------------------------------------------
# ------------------------------------------------------------------------------
# Proc http::ScheduleRequest
# ------------------------------------------------------------------------------
# Command to either begin the HTTP request, or add it to the appropriate queue.
# Called from two places in ConfigureNewSocket.
#
# Arguments:
# token - connection token (name of an array)
#
# Return Value: none
# ------------------------------------------------------------------------------
proc http::ScheduleRequest {token} {
variable $token
upvar 0 $token state
set tk [namespace tail $token]
Log >L$tk ScheduleRequest
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketPhQueue
variable socketClosing
variable socketPlayCmd
variable socketCoEvent
set Unfinished 0
set reusing $state(reusing)
set sockNew $state(sock)
# The "if" tests below: must test against the current values of
# socketWrState, socketRdState, and so the tests must be done here,
# not earlier in PreparePersistentConnection.
if {$state(alreadyQueued)} {
# The request has been appended to the queue of a persistent socket
# (that is scheduled to close and have its queue replayed).
#
# A write may or may not be in progress. There is no need to set
# socketWrState to prevent another call stealing write access - all
# subsequent calls on this socket will come here because the socket
# will close after the current read, and its
# socketClosing($connId) is 1.
##Log "HTTP request for token $token is queued"
|
| ︙ | ︙ | |||
1288 1289 1290 1291 1292 1293 1294 |
&& ($socketRdState($state(socketinfo)) ne "Rready")
} {
# A read is queued or in progress, but not a write. Cannot start the
# nonpipeline transaction, but must set socketWrState to prevent a
# pipelined request jumping the queue.
##Log "HTTP request for token $token is queued for nonpipeline use"
#Log re-use nonpipeline, GRANT delayed write access to $token in geturl
| < | | > > | < | > | > > | | | > | > > > | > | > > > > > < < | > > > | | < | | | | < < < < < < < < < < < < | | < | > | 1826 1827 1828 1829 1830 1831 1832 1833 1834 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 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 |
&& ($socketRdState($state(socketinfo)) ne "Rready")
} {
# A read is queued or in progress, but not a write. Cannot start the
# nonpipeline transaction, but must set socketWrState to prevent a
# pipelined request jumping the queue.
##Log "HTTP request for token $token is queued for nonpipeline use"
#Log re-use nonpipeline, GRANT delayed write access to $token in geturl
set socketWrState($state(socketinfo)) peNding
lappend socketWrQueue($state(socketinfo)) $token
} else {
if {$reusing && $state(-pipeline)} {
#Log new, init for pipelined, GRANT write access to $token in geturl
# DO NOT grant premature read access to the socket.
# set socketRdState($state(socketinfo)) $token
set socketWrState($state(socketinfo)) $token
} elseif {$reusing} {
# socketWrState is not used by this non-pipelined transaction.
# We cannot leave it as "Wready" because the next call to
# http::geturl with a pipelined transaction would conclude that the
# socket is available for writing.
#Log new, init for nonpipeline, GRANT r/w access to $token in geturl
set socketRdState($state(socketinfo)) $token
set socketWrState($state(socketinfo)) $token
} else {
}
# Process the request now.
# - Command is not called unless $state(sock) is a real socket handle
# and not a placeholder.
# - All (!$reusing) cases come here.
# - Some $reusing cases come here too if the connection is
# marked as ready. Those $reusing cases are:
# $reusing && ($socketWrState($state(socketinfo)) eq "Wready") &&
# EITHER !$pipeline && ($socketRdState($state(socketinfo)) eq "Rready")
# OR $pipeline
#
#Log ---- $state(socketinfo) << conn to $token for HTTP request (a)
##Log " ScheduleRequest" $token -- fileevent $state(sock) writable for $token
# Connect does its own fconfigure.
lassign $state(connArgs) proto phost srvurl
if {[catch {
fileevent $state(sock) writable \
[list http::Connect $token $proto $phost $srvurl]
} res opts]} {
# The socket no longer exists.
##Log bug -- socket gone -- $res -- $opts
}
}
return
}
# http::Connected --
#
# Callback used when the connection to the HTTP server is actually
# established.
#
# Arguments:
|
| ︙ | ︙ | |||
1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 |
variable http
variable urlTypes
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketClosing
variable socketPlayCmd
variable $token
upvar 0 $token state
set tk [namespace tail $token]
if {$state(reusing) && (!$state(-pipeline)) && ($state(-timeout) > 0)} {
set state(after) [after $state(-timeout) \
| > > | 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 |
variable http
variable urlTypes
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketPhQueue
variable socketClosing
variable socketPlayCmd
variable socketCoEvent
variable $token
upvar 0 $token state
set tk [namespace tail $token]
if {$state(reusing) && (!$state(-pipeline)) && ($state(-timeout) > 0)} {
set state(after) [after $state(-timeout) \
|
| ︙ | ︙ | |||
1420 1421 1422 1423 1424 1425 1426 |
set accept_types_seen 0
Log ^B$tk begin sending request - token $token
if {[catch {
set state(method) $how
puts $sock "$how $srvurl HTTP/$state(-protocol)"
| | > < | | | 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 |
set accept_types_seen 0
Log ^B$tk begin sending request - token $token
if {[catch {
set state(method) $how
puts $sock "$how $srvurl HTTP/$state(-protocol)"
set hostValue [GetFieldValue $state(-headers) Host]
if {$hostValue ne {}} {
# Allow Host spoofing. [Bug 928154]
regexp {^[^:]+} $hostValue state(host)
puts $sock "Host: $hostValue"
} elseif {$port == $defport} {
# Don't add port in this case, to handle broken servers. [Bug
# #504508]
set state(host) $host
puts $sock "Host: $host"
} else {
set state(host) $host
|
| ︙ | ︙ | |||
1456 1457 1458 1459 1460 1461 1462 | # and "state(-keepalive) 0". puts $sock "Connection: close" } # RFC7230 A.1 - "clients are encouraged not to send the # Proxy-Connection header field in any requests" set accept_encoding_seen 0 set content_type_seen 0 | | | 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 |
# and "state(-keepalive) 0".
puts $sock "Connection: close"
}
# RFC7230 A.1 - "clients are encouraged not to send the
# Proxy-Connection header field in any requests"
set accept_encoding_seen 0
set content_type_seen 0
foreach {key value} $state(-headers) {
set value [string map [list \n "" \r ""] $value]
set key [string map {" " -} [string trim $key]]
if {[string equal -nocase $key "host"]} {
continue
}
if {[string equal -nocase $key "accept-encoding"]} {
set accept_encoding_seen 1
|
| ︙ | ︙ | |||
1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 |
set msg {failed to use socket}
}
Finish $token $msg
} elseif {$state(status) ne "error"} {
Finish $token $err
}
}
}
# http::registerError
#
# Called (for example when processing TclTLS activity) to register
# an error for a connection on a specific socket. This helps
# http::Connected to deliver meaningful error messages, e.g. when a TLS
| > | 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 |
set msg {failed to use socket}
}
Finish $token $msg
} elseif {$state(status) ne "error"} {
Finish $token $err
}
}
return
}
# http::registerError
#
# Called (for example when processing TclTLS activity) to register
# an error for a connection on a specific socket. This helps
# http::Connected to deliver meaningful error messages, e.g. when a TLS
|
| ︙ | ︙ | |||
1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 |
proc http::DoneRequest {token} {
variable http
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketClosing
variable socketPlayCmd
variable $token
upvar 0 $token state
set tk [namespace tail $token]
set sock $state(sock)
# If pipelined, connect the next HTTP request to the socket.
| > > | 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 |
proc http::DoneRequest {token} {
variable http
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketPhQueue
variable socketClosing
variable socketPlayCmd
variable socketCoEvent
variable $token
upvar 0 $token state
set tk [namespace tail $token]
set sock $state(sock)
# If pipelined, connect the next HTTP request to the socket.
|
| ︙ | ︙ | |||
1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 |
lappend socketRdQueue($state(socketinfo)) $token
} else {
# In the pipelined case, connection for reading depends on the
# value of socketRdState.
# In the nonpipeline case, connection for reading always occurs.
ReceiveResponse $token
}
}
# http::ReceiveResponse
#
# Connects token to its socket for reading.
proc http::ReceiveResponse {token} {
variable $token
upvar 0 $token state
set tk [namespace tail $token]
set sock $state(sock)
#Log ---- $state(socketinfo) >> conn to $token for HTTP response
lassign [fconfigure $sock -translation] trRead trWrite
fconfigure $sock -translation [list auto $trWrite] \
-buffersize $state(-blocksize)
Log ^D$tk begin receiving response - token $token
| > | | | 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 |
lappend socketRdQueue($state(socketinfo)) $token
} else {
# In the pipelined case, connection for reading depends on the
# value of socketRdState.
# In the nonpipeline case, connection for reading always occurs.
ReceiveResponse $token
}
return
}
# http::ReceiveResponse
#
# Connects token to its socket for reading.
proc http::ReceiveResponse {token} {
variable $token
upvar 0 $token state
set tk [namespace tail $token]
set sock $state(sock)
#Log ---- $state(socketinfo) >> conn to $token for HTTP response
lassign [fconfigure $sock -translation] trRead trWrite
fconfigure $sock -translation [list auto $trWrite] \
-buffersize $state(-blocksize)
Log ^D$tk begin receiving response - token $token
coroutine ${token}--EventCoroutine http::Event $sock $token
if {[info exists state(-handler)] || [info exists state(-progress)]} {
fileevent $sock readable [list http::EventGateway $sock $token]
} else {
fileevent $sock readable ${token}--EventCoroutine
}
return
}
# http::EventGateway
#
|
| ︙ | ︙ | |||
1756 1757 1758 1759 1760 1761 1762 |
# used only if -handler or -progress is specified. In other cases,
# the coroutine is called directly.
proc http::EventGateway {sock token} {
variable $token
upvar 0 $token state
fileevent $sock readable {}
| | | | 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 |
# used only if -handler or -progress is specified. In other cases,
# the coroutine is called directly.
proc http::EventGateway {sock token} {
variable $token
upvar 0 $token state
fileevent $sock readable {}
catch {${token}--EventCoroutine} res opts
if {[info commands ${token}--EventCoroutine] ne {}} {
# The coroutine can be deleted by completion (a non-yield return), by
# http::Finish (when there is a premature end to the transaction), by
# http::reset or http::cleanup, or if the caller set option -channel
# but not option -handler: in the last case reading from the socket is
# now managed by commands ::http::Copy*, http::ReceiveChunked, and
# http::make-transformation-chunked.
#
|
| ︙ | ︙ | |||
1825 1826 1827 1828 1829 1830 1831 |
&& ([set token2 [lindex $socketWrQueue($connId) 0]
set ${token2}(-pipeline)
]
)
} {
# - The usual case for a pipelined connection, ready for a new request.
#Log pipelined, GRANT write access to $token2 in NextPipelinedWrite
| | | 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 |
&& ([set token2 [lindex $socketWrQueue($connId) 0]
set ${token2}(-pipeline)
]
)
} {
# - The usual case for a pipelined connection, ready for a new request.
#Log pipelined, GRANT write access to $token2 in NextPipelinedWrite
set conn [set ${token2}(connArgs)]
set socketWrState($connId) $token2
set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
# Connect does its own fconfigure.
fileevent $state(sock) writable [list http::Connect $token2 {*}$conn]
#Log ---- $connId << conn to $token2 for HTTP request (b)
# In the tests below, the next request will be nonpipeline.
|
| ︙ | ︙ | |||
1850 1851 1852 1853 1854 1855 1856 |
&& [info exists socketRdState($connId)]
&& ($socketRdState($connId) eq "Rready")
} {
# The case in which the next request will be non-pipelined, and the read
# and write queues is ready: which is the condition for a non-pipelined
# write.
| < < | | 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 |
&& [info exists socketRdState($connId)]
&& ($socketRdState($connId) eq "Rready")
} {
# The case in which the next request will be non-pipelined, and the read
# and write queues is ready: which is the condition for a non-pipelined
# write.
set conn [set ${token3}(connArgs)]
#Log nonpipeline, GRANT r/w access to $token3 in NextPipelinedWrite
set socketRdState($connId) $token3
set socketWrState($connId) $token3
set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
# Connect does its own fconfigure.
fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
#Log ---- $state(sock) << conn to $token3 for HTTP request (c)
|
| ︙ | ︙ | |||
1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 |
# - Because socketWrState($connId) is not set to Wready, the assignment
# of the connection to $token2 will be done elsewhere - by command
# http::KeepSocket when $socketRdState($connId) is set to "Rready".
#Log re-use nonpipeline, GRANT delayed write access to $token in NextP..
set socketWrState($connId) peNding
}
}
# http::CancelReadPipeline
#
# Cancel pipelined responses on a closing "Keep-Alive" socket.
#
# - Called by a variable trace on "unset socketRdState($connId)".
| > | 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 |
# - Because socketWrState($connId) is not set to Wready, the assignment
# of the connection to $token2 will be done elsewhere - by command
# http::KeepSocket when $socketRdState($connId) is set to "Rready".
#Log re-use nonpipeline, GRANT delayed write access to $token in NextP..
set socketWrState($connId) peNding
}
return
}
# http::CancelReadPipeline
#
# Cancel pipelined responses on a closing "Keep-Alive" socket.
#
# - Called by a variable trace on "unset socketRdState($connId)".
|
| ︙ | ︙ | |||
1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 |
set tk [namespace tail $token]
Log ^X$tk end of response "($msg)" - token $token
set ${token}(status) eof
Finish $token ;#$msg
}
set socketRdQueue($connId) {}
}
}
# http::CancelWritePipeline
#
# Cancel queued events on a closing "Keep-Alive" socket.
#
# - Called by a variable trace on "unset socketWrState($connId)".
| > | 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 |
set tk [namespace tail $token]
Log ^X$tk end of response "($msg)" - token $token
set ${token}(status) eof
Finish $token ;#$msg
}
set socketRdQueue($connId) {}
}
return
}
# http::CancelWritePipeline
#
# Cancel queued events on a closing "Keep-Alive" socket.
#
# - Called by a variable trace on "unset socketWrState($connId)".
|
| ︙ | ︙ | |||
1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 |
set tk [namespace tail $token]
Log ^X$tk end of response "($msg)" - token $token
set ${token}(status) eof
Finish $token ;#$msg
}
set socketWrQueue($connId) {}
}
}
# http::ReplayIfDead --
#
# - A query on a re-used persistent socket failed at the earliest opportunity,
# because the socket had been closed by the server. Keep the token, tidy up,
# and try to connect on a fresh socket.
| > | 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 |
set tk [namespace tail $token]
Log ^X$tk end of response "($msg)" - token $token
set ${token}(status) eof
Finish $token ;#$msg
}
set socketWrQueue($connId) {}
}
return
}
# http::ReplayIfDead --
#
# - A query on a re-used persistent socket failed at the earliest opportunity,
# because the socket had been closed by the server. Keep the token, tidy up,
# and try to connect on a fresh socket.
|
| ︙ | ︙ | |||
1971 1972 1973 1974 1975 1976 1977 | # # Arguments: # token Connection token. # # Side Effects: # Use the same token, but try to open a new socket. | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 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 |
#
# Arguments:
# token Connection token.
#
# Side Effects:
# Use the same token, but try to open a new socket.
proc http::ReplayIfDead {token doing} {
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketPhQueue
variable socketClosing
variable socketPlayCmd
variable socketCoEvent
variable $token
upvar 0 $token state
Log running http::ReplayIfDead for $token $doing
# 1. Merge the tokens for transactions in flight, the read (response) queue,
# and the write (request) queue.
set InFlightR {}
set InFlightW {}
# Obtain the tokens for transactions in flight.
if {$state(-pipeline)} {
# Two transactions may be in flight. The "read" transaction was first.
# It is unlikely that the server would close the socket if a response
# was pending; however, an earlier request (as well as the present
# request) may have been sent and ignored if the socket was half-closed
# by the server.
if { [info exists socketRdState($state(socketinfo))]
&& ($socketRdState($state(socketinfo)) ne "Rready")
} {
lappend InFlightR $socketRdState($state(socketinfo))
} elseif {($doing eq "read")} {
lappend InFlightR $token
}
if { [info exists socketWrState($state(socketinfo))]
&& $socketWrState($state(socketinfo)) ni {Wready peNding}
} {
lappend InFlightW $socketWrState($state(socketinfo))
} elseif {($doing eq "write")} {
lappend InFlightW $token
}
# Report any inconsistency of $token with socket*state.
if { ($doing eq "read")
&& [info exists socketRdState($state(socketinfo))]
&& ($token ne $socketRdState($state(socketinfo)))
} {
Log WARNING - ReplayIfDead pipelined token $token $doing \
ne socketRdState($state(socketinfo)) \
$socketRdState($state(socketinfo))
} elseif {
($doing eq "write")
&& [info exists socketWrState($state(socketinfo))]
&& ($token ne $socketWrState($state(socketinfo)))
} {
Log WARNING - ReplayIfDead pipelined token $token $doing \
ne socketWrState($state(socketinfo)) \
$socketWrState($state(socketinfo))
}
} else {
# One transaction should be in flight.
# socketRdState, socketWrQueue are used.
# socketRdQueue should be empty.
# Report any inconsistency of $token with socket*state.
if {$token ne $socketRdState($state(socketinfo))} {
Log WARNING - ReplayIfDead nonpipeline token $token $doing \
ne socketRdState($state(socketinfo)) \
$socketRdState($state(socketinfo))
}
# Report the inconsistency that socketRdQueue is non-empty.
if { [info exists socketRdQueue($state(socketinfo))]
&& ($socketRdQueue($state(socketinfo)) ne {})
} {
Log WARNING - ReplayIfDead nonpipeline token $token $doing \
has read queue socketRdQueue($state(socketinfo)) \
$socketRdQueue($state(socketinfo)) ne {}
}
lappend InFlightW $socketRdState($state(socketinfo))
set socketRdQueue($state(socketinfo)) {}
}
set newQueue {}
lappend newQueue {*}$InFlightR
lappend newQueue {*}$socketRdQueue($state(socketinfo))
lappend newQueue {*}$InFlightW
lappend newQueue {*}$socketWrQueue($state(socketinfo))
# 2. Tidy up token. This is a cut-down form of Finish/CloseSocket.
# Do not change state(status).
# No need to after cancel state(after) - either this is done in
# ReplayCore/ReInit, or Finish is called.
catch {close $state(sock)}
Unset $state(socketinfo)
# 2a. Tidy the tokens in the queues - this is done in ReplayCore/ReInit.
# - Transactions, if any, that are awaiting responses cannot be completed.
# They are listed for re-sending in newQueue.
# - All tokens are preserved for re-use by ReplayCore, and their variables
# will be re-initialised by calls to ReInit.
# - The relevant element of socketMapping, socketRdState, socketWrState,
# socketRdQueue, socketWrQueue, socketClosing, socketPlayCmd will be set
# to new values in ReplayCore.
ReplayCore $newQueue
return
}
# http::ReplayIfClose --
#
# A request on a socket that was previously "Connection: keep-alive" has
# received a "Connection: close" response header. The server supplies
# that response correctly, but any later requests already queued on this
|
| ︙ | ︙ | |||
2112 2113 2114 2115 2116 2117 2118 |
}
# 1. Create newQueue
set InFlightW {}
if {$Wstate ni {Wready peNding}} {
lappend InFlightW $Wstate
}
| | > | 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 |
}
# 1. Create newQueue
set InFlightW {}
if {$Wstate ni {Wready peNding}} {
lappend InFlightW $Wstate
}
##Log $Rqueue -- $InFlightW -- $Wqueue
set newQueue {}
lappend newQueue {*}$Rqueue
lappend newQueue {*}$InFlightW
lappend newQueue {*}$Wqueue
# 2. Cleanup - none needed, done by the caller.
ReplayCore $newQueue
return
}
# http::ReInit --
#
# Command to restore a token's state to a condition that
# makes it ready to replay a request.
#
|
| ︙ | ︙ | |||
2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 |
return 0
}
if {[info exists state(after)]} {
after cancel $state(after)
unset state(after)
}
# Don't alter state(status) - this would trigger http::wait if it is in use.
set tmpState $state(tmpState)
set tmpOpenCmd $state(tmpOpenCmd)
set tmpConnArgs $state(tmpConnArgs)
foreach name [array names state] {
if {$name ne "status"} {
| > > > > > | 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 |
return 0
}
if {[info exists state(after)]} {
after cancel $state(after)
unset state(after)
}
if {[info exists state(socketcoro)]} {
Log $token Cancel socket after-idle event (ReInit)
after cancel $state(socketcoro)
unset state(socketcoro)
}
# Don't alter state(status) - this would trigger http::wait if it is in use.
set tmpState $state(tmpState)
set tmpOpenCmd $state(tmpOpenCmd)
set tmpConnArgs $state(tmpConnArgs)
foreach name [array names state] {
if {$name ne "status"} {
|
| ︙ | ︙ | |||
2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 |
# Arguments:
# newQueue List of connection tokens.
#
# Side Effects:
# Use existing tokens, but try to open a new socket.
proc http::ReplayCore {newQueue} {
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketClosing
variable socketPlayCmd
if {[llength $newQueue] == 0} {
# Nothing to do.
return
}
##Log running ReplayCore for {*}$newQueue
| > > > > | 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 |
# Arguments:
# newQueue List of connection tokens.
#
# Side Effects:
# Use existing tokens, but try to open a new socket.
proc http::ReplayCore {newQueue} {
variable TmpSockCounter
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketPhQueue
variable socketClosing
variable socketPlayCmd
variable socketCoEvent
if {[llength $newQueue] == 0} {
# Nothing to do.
return
}
##Log running ReplayCore for {*}$newQueue
|
| ︙ | ︙ | |||
2241 2242 2243 2244 2245 2246 2247 |
set tmpOpenCmd $state(tmpOpenCmd)
set tmpConnArgs $state(tmpConnArgs)
unset state(tmpState)
unset state(tmpOpenCmd)
unset state(tmpConnArgs)
set state(reusing) 0
| | < < | | | < < < | < < < | < < | < < < < < < < < < < | < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > | < < | < < < < < | < < < | 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 |
set tmpOpenCmd $state(tmpOpenCmd)
set tmpConnArgs $state(tmpConnArgs)
unset state(tmpState)
unset state(tmpOpenCmd)
unset state(tmpConnArgs)
set state(reusing) 0
set state(ReusingPlaceholder) 0
set state(alreadyQueued) 0
# Give the socket a placeholder name before it is created.
set sock HTTP_PLACEHOLDER_[incr TmpSockCounter]
set state(sock) $sock
# Move the $newQueue into the placeholder socket's socketPhQueue.
set socketPhQueue($sock) {}
foreach tok $newQueue {
if {[ReInit $tok]} {
set ${tok}(reusing) 1
set ${tok}(sock) $sock
lappend socketPhQueue($sock) $tok
} else {
set ${tok}(reusing) 1
set ${tok}(sock) NONE
Finish $tok {cannot send this request again}
}
}
AsyncTransaction $token
return
}
# Data access functions:
# Data - the URL data
# Status - the transaction status: ok, reset, eof, timeout, error
# Code - the HTTP transaction code, e.g., 200
# Size - the size of the URL data
|
| ︙ | ︙ | |||
2378 2379 2380 2381 2382 2383 2384 |
}
proc http::error {token} {
variable $token
upvar 0 $token state
if {[info exists state(error)]} {
return $state(error)
}
| | | | > > > > > > > > > > > | < < | > | > > > > > > > > | < < < < > > | 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 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 |
}
proc http::error {token} {
variable $token
upvar 0 $token state
if {[info exists state(error)]} {
return $state(error)
}
return
}
# http::cleanup
#
# Garbage collect the state associated with a transaction
#
# Arguments
# token The token returned from http::geturl
#
# Side Effects
# unsets the state array
proc http::cleanup {token} {
variable $token
upvar 0 $token state
if {[info commands ${token}--EventCoroutine] ne {}} {
rename ${token}--EventCoroutine {}
}
if {[info commands ${token}--SocketCoroutine] ne {}} {
rename ${token}--SocketCoroutine {}
}
if {[info exists state(after)]} {
after cancel $state(after)
unset state(after)
}
if {[info exists state(socketcoro)]} {
Log $token Cancel socket after-idle event (cleanup)
after cancel $state(socketcoro)
unset state(socketcoro)
}
if {[info exists state]} {
unset state
}
return
}
# http::Connect
#
# This callback is made when an asyncronous connection completes.
#
# Arguments
# token The token returned from http::geturl
#
# Side Effects
# Sets the status of the connection, which unblocks
# the waiting geturl call
proc http::Connect {token proto phost srvurl} {
variable $token
upvar 0 $token state
set tk [namespace tail $token]
if {[catch {eof $state(sock)} tmp] || $tmp} {
set err "due to unexpected EOF"
} elseif {[set err [fconfigure $state(sock) -error]] ne ""} {
# set err is done in test
} else {
# All OK
set state(state) connecting
fileevent $state(sock) writable {}
::http::Connected $token $proto $phost $srvurl
return
}
# Error cases.
Log "WARNING - if testing, pay special attention to this\
case (GJ) which is seldom executed - token $token"
if {[info exists state(reusing)] && $state(reusing)} {
# The socket was closed at the server end, and closed at
# this end by http::CheckEof.
if {[TestForReplay $token write $err b]} {
return
}
# else:
# This is NOT a persistent socket that has been closed since its
# last use.
# If any other requests are in flight or pipelined/queued, they will
# be discarded.
}
Finish $token "connect failed $err"
return
}
# http::Write
#
# Write POST query data to the socket
#
# Arguments
# token The token for the connection
#
# Side Effects
# Write the socket and handle callbacks.
proc http::Write {token} {
variable http
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketPhQueue
variable socketClosing
variable socketPlayCmd
variable socketCoEvent
variable $token
upvar 0 $token state
set tk [namespace tail $token]
set sock $state(sock)
# Output a block. Tcl will buffer this if the socket blocks
|
| ︙ | ︙ | |||
2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 |
# Callback to the client after we've completely handled everything.
if {[string length $state(-queryprogress)]} {
eval $state(-queryprogress) \
[list $token $state(querylength) $state(queryoffset)]
}
}
# http::Event
#
# Handle input on the socket. This command is the core of
| > | > > | | 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 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 |
# Callback to the client after we've completely handled everything.
if {[string length $state(-queryprogress)]} {
eval $state(-queryprogress) \
[list $token $state(querylength) $state(queryoffset)]
}
return
}
# http::Event
#
# Handle input on the socket. This command is the core of
# the coroutine commands ${token}--EventCoroutine that are
# bound to "fileevent $sock readable" and process input.
#
# Arguments
# sock The socket receiving input.
# token The token returned from http::geturl
#
# Side Effects
# Read the socket and handle callbacks.
proc http::Event {sock token} {
variable http
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
variable socketPhQueue
variable socketClosing
variable socketPlayCmd
variable socketCoEvent
variable $token
upvar 0 $token state
set tk [namespace tail $token]
while 1 {
yield
##Log Event call - token $token
if {![info exists state]} {
Log "Event $sock with invalid token '$token' - remote close?"
if {!([catch {eof $sock} tmp] || $tmp)} {
if {[set d [read $sock]] ne ""} {
Log "WARNING: additional data left on closed socket\
- token $token"
}
}
Log ^X$tk end of response (token error) - token $token
CloseSocket $sock
|
| ︙ | ︙ | |||
2630 2631 2632 2633 2634 2635 2636 |
Log ^X$tk end of response (error) - token $token
Finish $token $nsl
return
}
} elseif {$nsl >= 0} {
##Log - connecting 1 - token $token
set state(state) "header"
| | | 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 |
Log ^X$tk end of response (error) - token $token
Finish $token $nsl
return
}
} elseif {$nsl >= 0} {
##Log - connecting 1 - token $token
set state(state) "header"
} elseif { ([catch {eof $sock} tmp] || $tmp)
&& [info exists state(reusing)]
&& $state(reusing)
} {
# The socket was closed at the server end, and we didn't notice.
# This is the first read - where the closure is usually first
# detected.
|
| ︙ | ︙ | |||
2669 2670 2671 2672 2673 2674 2675 |
set state(state) "connecting"
continue
# This was a "return" in the pre-coroutine code.
}
if { ([info exists state(connection)])
&& ([info exists socketMapping($state(socketinfo))])
| | | 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 |
set state(state) "connecting"
continue
# This was a "return" in the pre-coroutine code.
}
if { ([info exists state(connection)])
&& ([info exists socketMapping($state(socketinfo))])
&& ("keep-alive" in $state(connection))
&& ($state(-keepalive))
&& (!$state(reusing))
&& ($state(-pipeline))
} {
# Response headers received for first request on a
# persistent socket. Now ready for pipelined writes (if
# any).
|
| ︙ | ︙ | |||
2691 2692 2693 2694 2695 2696 2697 |
#
# If either the client or the server sends the "close" token in
# the Connection header, that request becomes the last one for
# the connection.
if { ([info exists state(connection)])
&& ([info exists socketMapping($state(socketinfo))])
| | > > > > > > > > > > > > > > < > > < | > > > > > > > > > > > > > > | 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 |
#
# If either the client or the server sends the "close" token in
# the Connection header, that request becomes the last one for
# the connection.
if { ([info exists state(connection)])
&& ([info exists socketMapping($state(socketinfo))])
&& ("close" in $state(connection))
&& ($state(-keepalive))
} {
# The server warns that it will close the socket after this
# response.
##Log WARNING - socket will close after response for $token
# Prepare data for a call to ReplayIfClose.
Log $token socket will close after this transaction
# 1. Cancel socket-assignment coro events that have not yet
# launched, and add the tokens to the write queue.
if {[info exists socketCoEvent($state(socketinfo))]} {
foreach {tok can} $socketCoEvent($state(socketinfo)) {
lappend socketWrQueue($state(socketinfo)) $tok
unset -nocomplain ${tok}(socketcoro)
after cancel $can
Log $tok Cancel socket after-idle event (Event)
Log Move $tok from socketCoEvent to socketWrQueue and cancel its after idle coro
}
set socketCoEvent($state(socketinfo)) {}
}
if { ($socketRdQueue($state(socketinfo)) ne {})
|| ($socketWrQueue($state(socketinfo)) ne {})
|| ($socketWrState($state(socketinfo)) ni
[list Wready peNding $token])
} {
set InFlightW $socketWrState($state(socketinfo))
if {$InFlightW in [list Wready peNding $token]} {
set InFlightW Wready
} else {
set msg "token ${InFlightW} is InFlightW"
##Log $msg - token $token
}
set socketPlayCmd($state(socketinfo)) \
[list ReplayIfClose $InFlightW \
$socketRdQueue($state(socketinfo)) \
$socketWrQueue($state(socketinfo))]
# - All tokens are preserved for re-use by ReplayCore.
# - Queues are preserved in case of Finish with error,
# but are not used for anything else because
# socketClosing(*) is set below.
# - Cancel the state(after) timeout events.
foreach tokenVal $socketRdQueue($state(socketinfo)) {
if {[info exists ${tokenVal}(after)]} {
after cancel [set ${tokenVal}(after)]
unset ${tokenVal}(after)
}
# Tokens in the read queue have no (socketcoro) to
# cancel.
}
} else {
set socketPlayCmd($state(socketinfo)) \
{ReplayIfClose Wready {} {}}
}
# Do not allow further connections on this socket (but
# geturl can add new requests to the replay).
set socketClosing($state(socketinfo)) 1
}
set state(state) body
# According to
# https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Connection
# any comma-separated "Connection:" list implies keep-alive, but I
# don't see this in the RFC so we'll play safe and
# scan any list for "close".
# Done here to support combining duplicate header field's values.
if { [info exists state(connection)]
&& ("close" ni $state(connection))
&& ("keep-alive" ni $state(connection))
} {
lappend state(connection) "keep-alive"
}
# If doing a HEAD, then we won't get any body
if {$state(-validate)} {
Log ^F$tk end of response for HEAD request - token $token
set state(state) complete
Eot $token
return
|
| ︙ | ︙ | |||
2762 2763 2764 2765 2766 2767 2768 |
# by using chunked Transfer-Encoding.
# - Do not worry here about the case (Connection: close) because
# the server should close the connection.
# - IF (NOT Connection: close) AND (NOT chunked encoding) AND
# (totalsize == 0).
if { (!( [info exists state(connection)]
| | | 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 |
# by using chunked Transfer-Encoding.
# - Do not worry here about the case (Connection: close) because
# the server should close the connection.
# - IF (NOT Connection: close) AND (NOT chunked encoding) AND
# (totalsize == 0).
if { (!( [info exists state(connection)]
&& ("close" in $state(connection))
)
)
&& (![info exists state(transfer)])
&& ($state(totalsize) == 0)
} {
set msg {body size is 0 and no events likely - complete}
Log "$msg - token $token"
|
| ︙ | ︙ | |||
2794 2795 2796 2797 2798 2799 2800 |
if {[info exists state(-channel)]} {
if {$state(binary) || [llength [ContentEncoding $token]]} {
fconfigure $state(-channel) -translation binary
}
if {![info exists state(-handler)]} {
# Initiate a sequence of background fcopies.
fileevent $sock readable {}
| | | 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 |
if {[info exists state(-channel)]} {
if {$state(binary) || [llength [ContentEncoding $token]]} {
fconfigure $state(-channel) -translation binary
}
if {![info exists state(-handler)]} {
# Initiate a sequence of background fcopies.
fileevent $sock readable {}
rename ${token}--EventCoroutine {}
CopyStart $sock $token
return
}
}
} elseif {$nhl > 0} {
# Process header lines.
##Log header - token $token - $line
|
| ︙ | ︙ | |||
2828 2829 2830 2831 2832 2833 2834 |
}
transfer-encoding {
set state(transfer) \
[string trim [string tolower $value]]
}
proxy-connection -
connection {
| < | < < < < < < < < < < < < < < | | < < | | | < | | 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 |
}
transfer-encoding {
set state(transfer) \
[string trim [string tolower $value]]
}
proxy-connection -
connection {
# RFC 7230 Section 6.1 states that a comma-separated
# list is an acceptable value.
foreach el [SplitCommaSeparatedFieldValue $value] {
lappend state(connection) [string tolower $el]
}
}
upgrade {
set state(upgrade) [string trim $value]
}
set-cookie {
if {$http(-cookiejar) ne ""} {
ParseCookie $token [string trim $value]
}
}
}
|
| ︙ | ︙ | |||
3042 3043 3044 3045 3046 3047 3048 | [list $token $state(totalsize) $state(currentsize)] } } } # catch as an Eot above may have closed the socket already # $state(state) may be connecting, header, body, or complete | | > | 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 |
[list $token $state(totalsize) $state(currentsize)]
}
}
}
# catch as an Eot above may have closed the socket already
# $state(state) may be connecting, header, body, or complete
if {(![catch {eof $sock} eof]) && $eof} {
# [eof sock] succeeded and the result was 1
##Log eof - token $token
if {[info exists $token]} {
set state(connection) close
if {$state(state) eq "complete"} {
# This includes all cases in which the transaction
# can be completed by eof.
# The value "complete" is set only in http::Event, and it is
|
| ︙ | ︙ | |||
3064 3065 3066 3067 3068 3069 3070 |
Eot $token eof
}
} else {
# open connection closed on a token that has been cleaned up.
Log ^X$tk end of response (token error) - token $token
CloseSocket $sock
}
| | | > > | 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 |
Eot $token eof
}
} else {
# open connection closed on a token that has been cleaned up.
Log ^X$tk end of response (token error) - token $token
CloseSocket $sock
}
} else {
# EITHER [eof sock] failed - presumed done by Eot
# OR [eof sock] succeeded and the result was 0
}
}
return
}
# http::TestForReplay
#
# Command called if eof is discovered when a socket is first used for a
# new transaction. Typically this occurs if a persistent socket is used
# after a period of idleness and the server has half-closed the socket.
|
| ︙ | ︙ | |||
3237 3238 3239 3240 3241 3242 3243 |
dict set realopts value $cookieval
{*}$http(-cookiejar) storeCookie $realopts
}
# http::getTextLine --
#
# Get one line with the stream in crlf mode.
| | > | 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 |
dict set realopts value $cookieval
{*}$http(-cookiejar) storeCookie $realopts
}
# http::getTextLine --
#
# Get one line with the stream in crlf mode.
# Used if Transfer-Encoding is chunked, to read the line that
# reports the size of the following chunk.
# Empty line is not distinguished from eof. The caller must
# be able to handle this.
#
# Arguments
# sock The socket receiving input.
#
# Results:
|
| ︙ | ︙ | |||
3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 |
return $r
}
# http::BlockingRead
#
# Replacement for a blocking read.
# The caller must be a coroutine.
proc http::BlockingRead {sock size} {
if {$size < 1} {
return
}
set result {}
while 1 {
set need [expr {$size - [string length $result]}]
set block [read $sock $need]
| > > | | | | 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 |
return $r
}
# http::BlockingRead
#
# Replacement for a blocking read.
# The caller must be a coroutine.
# Used when we expect to read a chunked-encoding
# chunk of known size.
proc http::BlockingRead {sock size} {
if {$size < 1} {
return
}
set result {}
while 1 {
set need [expr {$size - [string length $result]}]
set block [read $sock $need]
set eof [expr {[catch {eof $sock} tmp] || $tmp}]
append result $block
if {[string length $result] >= $size || $eof} {
return $result
} else {
yield
}
}
}
# http::BlockingGets
#
# Replacement for a blocking gets.
# The caller must be a coroutine.
# Empty line is not distinguished from eof. The caller must
# be able to handle this.
proc http::BlockingGets {sock} {
while 1 {
set count [gets $sock line]
set eof [expr {[catch {eof $sock} tmp] || $tmp}]
if {$count >= 0 || $eof} {
return $line
} else {
yield
}
}
}
# http::CopyStart
#
# Error handling wrapper around fcopy
#
# Arguments
# sock The socket to copy from
# token The token returned from http::geturl
#
# Side Effects
# This closes the connection upon error
proc http::CopyStart {sock token {initial 1}} {
upvar 0 $token state
if {[info exists state(transfer)] && $state(transfer) eq "chunked"} {
foreach coding [ContentEncoding $token] {
lappend state(zlib) [zlib stream $coding]
}
make-transformation-chunked $sock [namespace code [list CopyChunk $token]]
} else {
if {$initial} {
|
| ︙ | ︙ | |||
3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 |
# solution.
fcopy $sock $state(-channel) -size $state(-blocksize) -command \
[list http::CopyDone $token]
} err]} {
Finish $token $err
}
}
}
proc http::CopyChunk {token chunk} {
upvar 0 $token state
if {[set count [string length $chunk]]} {
incr state(currentsize) $count
if {[info exists state(zlib)]} {
| > | 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 |
# solution.
fcopy $sock $state(-channel) -size $state(-blocksize) -command \
[list http::CopyDone $token]
} err]} {
Finish $token $err
}
}
return
}
proc http::CopyChunk {token chunk} {
upvar 0 $token state
if {[set count [string length $chunk]]} {
incr state(currentsize) $count
if {[info exists state(zlib)]} {
|
| ︙ | ︙ | |||
3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 |
}
puts -nonewline $state(-channel) $excess
foreach stream $state(zlib) { $stream close }
unset state(zlib)
}
Eot $token ;# FIX ME: pipelining.
}
}
# http::CopyDone
#
# fcopy completion callback
#
# Arguments
| > | 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 |
}
puts -nonewline $state(-channel) $excess
foreach stream $state(zlib) { $stream close }
unset state(zlib)
}
Eot $token ;# FIX ME: pipelining.
}
return
}
# http::CopyDone
#
# fcopy completion callback
#
# Arguments
|
| ︙ | ︙ | |||
3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 |
if {[string length $error]} {
Finish $token $error
} elseif {[catch {eof $sock} iseof] || $iseof} {
Eot $token
} else {
CopyStart $sock $token 0
}
}
# http::Eot
#
# Called when either:
# a. An eof condition is detected on the socket.
# b. The client decides that the response is complete.
| > | 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 |
if {[string length $error]} {
Finish $token $error
} elseif {[catch {eof $sock} iseof] || $iseof} {
Eot $token
} else {
CopyStart $sock $token 0
}
return
}
# http::Eot
#
# Called when either:
# a. An eof condition is detected on the socket.
# b. The client decides that the response is complete.
|
| ︙ | ︙ | |||
3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 |
}
# Translate text line endings.
set state(body) [string map {\r\n \n \r \n} $state(body)]
}
}
Finish $token $reason
}
# http::wait --
#
# See documentation for details.
#
# Arguments:
| > | 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 |
}
# Translate text line endings.
set state(body) [string map {\r\n \n \r \n} $state(body)]
}
}
Finish $token $reason
return
}
# http::wait --
#
# See documentation for details.
#
# Arguments:
|
| ︙ | ︙ | |||
3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 |
if {
![info exists http(-proxyport)] ||
![string length $http(-proxyport)]
} {
set http(-proxyport) 8080
}
return [list $http(-proxyhost) $http(-proxyport)]
}
}
# http::CharsetToEncoding --
#
# Tries to map a given IANA charset to a tcl encoding. If no encoding
# can be found, returns binary.
| > > | 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 |
if {
![info exists http(-proxyport)] ||
![string length $http(-proxyport)]
} {
set http(-proxyport) 8080
}
return [list $http(-proxyhost) $http(-proxyport)]
} else {
return
}
}
# http::CharsetToEncoding --
#
# Tries to map a given IANA charset to a tcl encoding. If no encoding
# can be found, returns binary.
|
| ︙ | ︙ | |||
3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 |
if {[string length $chunk] == 0} {
# channel might have been closed in the callback
catch {chan event $chan readable {}}
return
}
}
}
proc http::make-transformation-chunked {chan command} {
coroutine [namespace current]::dechunk$chan ::http::ReceiveChunked $chan $command
chan event $chan readable [namespace current]::dechunk$chan
}
# Local variables:
# indent-tabs-mode: t
# End:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 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 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 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 |
if {[string length $chunk] == 0} {
# channel might have been closed in the callback
catch {chan event $chan readable {}}
return
}
}
}
# http::SplitCommaSeparatedFieldValue --
# Return the individual values of a comma-separated field value.
#
# Arguments:
# fieldValue Comma-separated header field value.
#
# Results:
# List of values.
proc http::SplitCommaSeparatedFieldValue {fieldValue} {
set r {}
foreach el [split $fieldValue ,] {
lappend r [string trim $el]
}
return $r
}
# http::GetFieldValue --
# Return the value of a header field.
#
# Arguments:
# headers Headers key-value list
# fieldName Name of header field whose value to return.
#
# Results:
# The value of the fieldName header field
#
# Field names are matched case-insensitively (RFC 7230 Section 3.2).
#
# If the field is present multiple times, it is assumed that the field is
# defined as a comma-separated list and the values are combined (by separating
# them with commas, see RFC 7230 Section 3.2.2) and returned at once.
proc http::GetFieldValue {headers fieldName} {
set r {}
foreach {field value} $headers {
if {[string equal -nocase $fieldName $field]} {
if {$r eq {}} {
set r $value
} else {
append r ", $value"
}
}
}
return $r
}
proc http::make-transformation-chunked {chan command} {
coroutine [namespace current]::dechunk$chan ::http::ReceiveChunked $chan $command
chan event $chan readable [namespace current]::dechunk$chan
return
}
# ------------------------------------------------------------------------------
# Proc http::socket
# ------------------------------------------------------------------------------
# This command is a drop-in replacement for ::socket.
# Arguments and return value as for ::socket.
#
# Notes.
# - http::socket is specified in place of ::socket by the definition of urlTypes
# in the namespace header of this file (http.tcl).
# - The command makes a simple call to ::socket unless the user has called
# http::config to change the value of -threadlevel from the default value 0.
# - For -threadlevel 1 or 2, if the Thread package is available, the command
# waits in the event loop while the socket is opened in another thread. This
# is a workaround for bug [824251] - it prevents http::geturl from blocking
# the event loop if the DNS lookup or server connection is slow.
# - FIXME Use a thread pool if connections are very frequent.
# - FIXME The peer thread can transfer the socket only to the main interpreter
# in the present thread. Therefore this code works only if this script runs
# in the main interpreter. In a child interpreter, the parent must alias a
# command to ::http::socket in the child, run http::socket in the parent,
# and then transfer the socket to the child.
# - The http::socket command is simple, and can easily be replaced with an
# alternative command that uses a different technique to open a socket while
# entering the event loop.
# ------------------------------------------------------------------------------
proc http::socket {args} {
variable ThreadVar
variable ThreadCounter
variable http
LoadThreadIfNeeded
set targ [lsearch -exact $args -token]
if {$targ != -1} {
set token [lindex $args $targ+1]
set args [lreplace $args $targ $targ+1]
upvar 0 $token state
}
if {!$http(usingThread)} {
# Use plain "::socket". This is the default.
return [eval ::socket $args]
}
set defcmd ::socket
set sockargs $args
set script "
[list proc ::SockInThread {caller defcmd sockargs} [info body http::SockInThread]]
[list ::SockInThread [thread::id] $defcmd $sockargs]
"
set state(tid) [thread::create]
set varName ::http::ThreadVar([incr ThreadCounter])
thread::send -async $state(tid) $script $varName
Log >T Thread Start Wait $args -- coro [info coroutine] $varName
if {[info coroutine] ne {}} {
# All callers in the http package are coroutines launched by
# the event loop.
# The cwait command requires a coroutine because it yields
# to the caller; $varName is traced and the coroutine resumes
# when the variable is written.
cwait $varName
} else {
return -code error {code must run in a coroutine}
# For testing with a non-coroutine caller outside the http package.
# vwait $varName
}
Log >U Thread End Wait $args -- coro [info coroutine] $varName [set $varName]
thread::release $state(tid)
set state(tid) {}
lassign [set $varName] catchCode errdict sock
unset $varName
dict set errdict -code $catchCode
return -options $errdict $sock
}
# The commands below are dependencies of http::socket and
# are not used elsewhere.
# ------------------------------------------------------------------------------
# Proc http::LoadThreadIfNeeded
# ------------------------------------------------------------------------------
# Command to load the Thread package if it is needed. If it is needed and not
# loadable, the outcome depends on $http(-threadlevel):
# value 0 => Thread package not required, no problem
# value 1 => operate as if -threadlevel 0
# value 2 => error return
#
# Arguments: none
# Return Value: none
# ------------------------------------------------------------------------------
proc http::LoadThreadIfNeeded {} {
variable http
if {$http(usingThread) || ($http(-threadlevel) == 0)} {
return
}
if {[catch {package require Thread}]} {
if {$http(-threadlevel) == 2} {
set msg {[http::config -threadlevel] has value 2,\
but the Thread package is not available}
return -code error $msg
}
return
}
set http(usingThread) 1
return
}
# ------------------------------------------------------------------------------
# Proc http::SockInThread
# ------------------------------------------------------------------------------
# Command http::socket is a ::socket replacement. It defines and runs this
# command, http::SockInThread, in a peer thread.
#
# Arguments:
# caller
# defcmd
# sockargs
#
# Return value: list of values that describe the outcome. The return is
# intended to be a normal (non-error) return in all cases.
# ------------------------------------------------------------------------------
proc http::SockInThread {caller defcmd sockargs} {
package require Thread
set catchCode [catch {eval $defcmd $sockargs} sock errdict]
if {$catchCode == 0} {
set catchCode [catch {thread::transfer $caller $sock; set sock} sock errdict]
}
return [list $catchCode $errdict $sock]
}
# ------------------------------------------------------------------------------
# Proc ::http::cwaiter::cwait
# ------------------------------------------------------------------------------
# Command to substitute for vwait, without the ordering issues.
# A command that uses cwait must be a coroutine that is launched by an event,
# e.g. fileevent or after idle, and has no calling code to be resumed upon
# "yield". It cannot return a value.
#
# Arguments:
# varName - fully-qualified name of the variable that the calling script
# will write to resume the coroutine. Any scalar variable or
# array element is permitted.
# coroName - (optional) name of the coroutine to be called when varName is
# written - defaults to this coroutine
# timeout - (optional) timeout value in ms
# timeoutValue - (optional) value to assign to varName if there is a timeout
#
# Return Value: none
# ------------------------------------------------------------------------------
namespace eval ::http::cwaiter {
namespace export cwait
variable log {}
variable logOn 0
}
proc ::http::cwaiter::cwait {
varName {coroName {}} {timeout {}} {timeoutValue {}}
} {
set thisCoro [info coroutine]
if {$thisCoro eq {}} {
return -code error {cwait cannot be called outside a coroutine}
}
if {$coroName eq {}} {
set coroName $thisCoro
}
if {[string range $varName 0 1] ne {::}} {
return -code error {argument varName must be fully qualified}
}
if {$timeout eq {}} {
set toe {}
} elseif {[string is integer -strict $timeout] && ($timeout > 0)} {
set toe [after $timeout [list set $varName $timeoutValue]]
} else {
return -code error {if timeout is supplied it must be a positive integer}
}
set cmd [list ::http::cwaiter::CwaitHelper $varName $coroName $toe]
trace add variable $varName write $cmd
CoLog "Yield $varName $coroName"
yield
CoLog "Resume $varName $coroName"
return
}
# ------------------------------------------------------------------------------
# Proc ::http::cwaiter::CwaitHelper
# ------------------------------------------------------------------------------
# Helper command called by the trace set by cwait.
# - Ignores the arguments added by trace.
# - A simple call to $coroName works, and in error cases gives a suitable stack
# trace, but because it is inside a trace the headline error message is
# something like {can't set "::Result(6)": error}, not the actual
# error. So let the trace command return.
# - Remove the trace immediately. We don't want multiple calls.
# ------------------------------------------------------------------------------
proc ::http::cwaiter::CwaitHelper {varName coroName toe args} {
CoLog "got $varName for $coroName"
set cmd [list ::http::cwaiter::CwaitHelper $varName $coroName $toe]
trace remove variable $varName write $cmd
after cancel $toe
after 0 $coroName
return
}
# ------------------------------------------------------------------------------
# Proc ::http::cwaiter::LogInit
# ------------------------------------------------------------------------------
# Call this command to initiate debug logging and clear the log.
# ------------------------------------------------------------------------------
proc ::http::cwaiter::LogInit {} {
variable log
variable logOn
set log {}
set logOn 1
return
}
proc ::http::cwaiter::LogRead {} {
variable log
return $log
}
proc ::http::cwaiter::CoLog {msg} {
variable log
variable logOn
if {$logOn} {
append log $msg \n
}
return
}
namespace eval ::http {
namespace import ::http::cwaiter::*
}
# Local variables:
# indent-tabs-mode: t
# End:
|
Changes to library/http/pkgIndex.tcl.
1 |
if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
| | | 1 2 |
if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
package ifneeded http 2.10a4 [list tclPkgSetup $dir http 2.10a4 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
|
Changes to library/init.tcl.
| ︙ | ︙ | |||
43 44 45 46 47 48 49 |
#
# (Ticket 41c9857bdd) In a safe interpreter, this file does not set
# ::auto_path (other than to {} if it is undefined). The caller, typically
# a Safe Base command, is responsible for setting ::auto_path.
if {![info exists auto_path]} {
if {[info exists env(TCLLIBPATH)] && (![interp issafe])} {
| | > > > > > > > > | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 |
#
# (Ticket 41c9857bdd) In a safe interpreter, this file does not set
# ::auto_path (other than to {} if it is undefined). The caller, typically
# a Safe Base command, is responsible for setting ::auto_path.
if {![info exists auto_path]} {
if {[info exists env(TCLLIBPATH)] && (![interp issafe])} {
set auto_path [apply {{} {
lmap path $::env(TCLLIBPATH) {
# Paths relative to unresolvable home dirs are ignored
if {[catch {file tildeexpand $path} expanded_path]} {
continue
}
set expanded_path
}
}}]
} else {
set auto_path ""
}
}
namespace eval tcl {
if {![interp issafe]} {
variable Dir
|
| ︙ | ︙ |
Changes to library/manifest.txt.
1 2 3 4 5 6 7 |
###
# Package manifest for all Tcl packages included in the /library file system
###
apply {{dir} {
set ::test [info script]
set isafe [interp issafe]
foreach {safe package version file} {
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
###
# Package manifest for all Tcl packages included in the /library file system
###
apply {{dir} {
set ::test [info script]
set isafe [interp issafe]
foreach {safe package version file} {
0 http 2.10a4 {http http.tcl}
1 msgcat 1.7.1 {msgcat msgcat.tcl}
1 opt 0.4.8 {opt optparse.tcl}
0 cookiejar 0.2.0 {cookiejar cookiejar.tcl}
0 tcl::idna 1.0.1 {cookiejar idna.tcl}
0 platform 1.0.18 {platform platform.tcl}
0 platform::shell 1.1.4 {platform shell.tcl}
1 tcltest 2.5.5 {tcltest tcltest.tcl}
} {
if {$isafe && !$safe} continue
package ifneeded $package $version [list source [file join $dir {*}$file]]
}
}} $dir
|
Changes to library/safe.tcl.
| ︙ | ︙ | |||
729 730 731 732 733 734 735 |
}
# AliasFileSubcommand handles selected subcommands of [file] in safe
# interpreters that are *almost* safe. In particular, it just acts to
# prevent discovery of what home directories exist.
proc ::safe::AliasFileSubcommand {child subcommand name} {
| < < < | 729 730 731 732 733 734 735 736 737 738 739 740 741 742 |
}
# AliasFileSubcommand handles selected subcommands of [file] in safe
# interpreters that are *almost* safe. In particular, it just acts to
# prevent discovery of what home directories exist.
proc ::safe::AliasFileSubcommand {child subcommand name} {
tailcall ::interp invokehidden $child tcl:file:$subcommand $name
}
# AliasGlob is the target of the "glob" alias in safe interpreters.
proc ::safe::AliasGlob {child args} {
Log $child "GLOB ! $args" NOTICE
|
| ︙ | ︙ |
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.5.5 [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.5.5
# 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]
|
| ︙ | ︙ | |||
2137 2138 2139 2140 2141 2142 2143 |
}
}
}
if {[IsVerbose msec] || [IsVerbose usec]} {
set t [expr {[clock microseconds] - $timeStart}]
if {[IsVerbose usec]} {
| | | 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 |
}
}
}
if {[IsVerbose msec] || [IsVerbose usec]} {
set t [expr {[clock microseconds] - $timeStart}]
if {[IsVerbose usec]} {
puts [outputChannel] "++++ $name took $t \xB5s"
}
if {[IsVerbose msec]} {
puts [outputChannel] "++++ $name took [expr {round($t/1000.)}] ms"
}
}
# if skipped, it is safe to return here
|
| ︙ | ︙ |
Changes to library/tm.tcl.
| ︙ | ︙ | |||
334 335 336 337 338 339 340 |
for {set n $minor} {$n >= 0} {incr n -1} {
foreach ev [::list \
TCL${major}.${n}_TM_PATH \
TCL${major}_${n}_TM_PATH \
] {
if {![info exists env($ev)]} continue
foreach p [split $env($ev) $sep] {
| > > | > | 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 |
for {set n $minor} {$n >= 0} {incr n -1} {
foreach ev [::list \
TCL${major}.${n}_TM_PATH \
TCL${major}_${n}_TM_PATH \
] {
if {![info exists env($ev)]} continue
foreach p [split $env($ev) $sep] {
# Paths relative to unresolvable home dirs are ignored
if {![catch {file tildeexpand $p} expanded_path]} {
path add $expanded_path
}
}
}
}
return
}
# ::tcl::tm::roots --
|
| ︙ | ︙ |
Changes to library/tzdata/America/Punta_Arenas.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
{-1241290800 -14400 1 -05}
{-1222977600 -18000 0 -05}
{-1209754800 -14400 1 -05}
{-1191355200 -18000 0 -05}
{-1178132400 -14400 0 -04}
{-870552000 -18000 0 -05}
{-865278000 -14400 0 -04}
{-718056000 -18000 0 -05}
{-713649600 -14400 0 -04}
{-36619200 -10800 1 -04}
{-23922000 -14400 0 -04}
{-3355200 -10800 1 -04}
{7527600 -14400 0 -04}
{24465600 -10800 1 -04}
| > | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
{-1241290800 -14400 1 -05}
{-1222977600 -18000 0 -05}
{-1209754800 -14400 1 -05}
{-1191355200 -18000 0 -05}
{-1178132400 -14400 0 -04}
{-870552000 -18000 0 -05}
{-865278000 -14400 0 -04}
{-736632000 -14400 1 -04}
{-718056000 -18000 0 -05}
{-713649600 -14400 0 -04}
{-36619200 -10800 1 -04}
{-23922000 -14400 0 -04}
{-3355200 -10800 1 -04}
{7527600 -14400 0 -04}
{24465600 -10800 1 -04}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Santiago.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 |
{-1222977600 -18000 0 -05}
{-1209754800 -14400 1 -05}
{-1191355200 -18000 0 -05}
{-1178132400 -14400 0 -04}
{-870552000 -18000 0 -05}
{-865278000 -14400 0 -04}
{-740520000 -10800 1 -03}
| | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
{-1222977600 -18000 0 -05}
{-1209754800 -14400 1 -05}
{-1191355200 -18000 0 -05}
{-1178132400 -14400 0 -04}
{-870552000 -18000 0 -05}
{-865278000 -14400 0 -04}
{-740520000 -10800 1 -03}
{-736635600 -14400 1 -04}
{-718056000 -18000 0 -05}
{-713649600 -14400 0 -04}
{-36619200 -10800 1 -04}
{-23922000 -14400 0 -04}
{-3355200 -10800 1 -04}
{7527600 -14400 0 -04}
{24465600 -10800 1 -04}
|
| ︙ | ︙ | |||
127 128 129 130 131 132 133 |
{1554606000 -14400 0 -04}
{1567915200 -10800 1 -04}
{1586055600 -14400 0 -04}
{1599364800 -10800 1 -04}
{1617505200 -14400 0 -04}
{1630814400 -10800 1 -04}
{1648954800 -14400 0 -04}
| | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 |
{1554606000 -14400 0 -04}
{1567915200 -10800 1 -04}
{1586055600 -14400 0 -04}
{1599364800 -10800 1 -04}
{1617505200 -14400 0 -04}
{1630814400 -10800 1 -04}
{1648954800 -14400 0 -04}
{1662868800 -10800 1 -04}
{1680404400 -14400 0 -04}
{1693713600 -10800 1 -04}
{1712458800 -14400 0 -04}
{1725768000 -10800 1 -04}
{1743908400 -14400 0 -04}
{1757217600 -10800 1 -04}
{1775358000 -14400 0 -04}
|
| ︙ | ︙ |
Changes to library/tzdata/Antarctica/Vostok.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Asia/Urumqi)]} {
LoadTimeZoneFile Asia/Urumqi
}
set TZData(:Antarctica/Vostok) $TZData(:Asia/Urumqi)
|
Changes to library/tzdata/Arctic/Longyearbyen.
1 | # created by tools/tclZIC.tcl - do not edit | | | | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Europe/Berlin)]} {
LoadTimeZoneFile Europe/Berlin
}
set TZData(:Arctic/Longyearbyen) $TZData(:Europe/Berlin)
|
Changes to library/tzdata/Asia/Brunei.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Asia/Kuching)]} {
LoadTimeZoneFile Asia/Kuching
}
set TZData(:Asia/Brunei) $TZData(:Asia/Kuching)
|
Changes to library/tzdata/Asia/Ho_Chi_Minh.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Ho_Chi_Minh) {
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Ho_Chi_Minh) {
{-9223372036854775808 25590 0 LMT}
{-2004073590 25590 0 PLMT}
{-1851577590 25200 0 +07}
{-852105600 28800 0 +08}
{-782643600 32400 0 +09}
{-767869200 25200 0 +07}
{-718095600 28800 0 +08}
{-457776000 25200 0 +07}
{-315648000 28800 0 +08}
|
| ︙ | ︙ |
Changes to library/tzdata/Asia/Kuala_Lumpur.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < < < < < < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Asia/Singapore)]} {
LoadTimeZoneFile Asia/Singapore
}
set TZData(:Asia/Kuala_Lumpur) $TZData(:Asia/Singapore)
|
Changes to library/tzdata/Asia/Tehran.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Tehran) {
{-9223372036854775808 12344 0 LMT}
{-1704165944 12344 0 TMT}
| | > | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Tehran) {
{-9223372036854775808 12344 0 LMT}
{-1704165944 12344 0 TMT}
{-1090466744 12600 0 +0330}
{227820600 16200 1 +0330}
{246227400 14400 0 +04}
{259617600 18000 1 +04}
{271108800 14400 0 +04}
{283982400 12600 0 +0330}
{296598600 16200 1 +0330}
{306531000 12600 0 +0330}
{322432200 16200 1 +0330}
{338499000 12600 0 +0330}
{673216200 16200 1 +0330}
{685481400 12600 0 +0330}
{701209800 16200 1 +0330}
{717103800 12600 0 +0330}
|
| ︙ | ︙ | |||
68 69 70 71 72 73 74 |
{1569094200 12600 0 +0330}
{1584736200 16200 1 +0330}
{1600630200 12600 0 +0330}
{1616358600 16200 1 +0330}
{1632252600 12600 0 +0330}
{1647894600 16200 1 +0330}
{1663788600 12600 0 +0330}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 69 70 71 72 73 74 75 76 |
{1569094200 12600 0 +0330}
{1584736200 16200 1 +0330}
{1600630200 12600 0 +0330}
{1616358600 16200 1 +0330}
{1632252600 12600 0 +0330}
{1647894600 16200 1 +0330}
{1663788600 12600 0 +0330}
}
|
Changes to library/tzdata/Atlantic/Jan_Mayen.
1 | # created by tools/tclZIC.tcl - do not edit | | | | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Europe/Berlin)]} {
LoadTimeZoneFile Europe/Berlin
}
set TZData(:Atlantic/Jan_Mayen) $TZData(:Europe/Berlin)
|
Changes to library/tzdata/Atlantic/Reykjavik.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Africa/Abidjan)]} {
LoadTimeZoneFile Africa/Abidjan
}
set TZData(:Atlantic/Reykjavik) $TZData(:Africa/Abidjan)
|
Deleted library/tzdata/Canada/East-Saskatchewan.
|
| < < < < < |
Changes to library/tzdata/Europe/Amsterdam.
1 | # created by tools/tclZIC.tcl - do not edit | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Europe/Brussels)]} {
LoadTimeZoneFile Europe/Brussels
}
set TZData(:Europe/Amsterdam) $TZData(:Europe/Brussels)
|
Changes to library/tzdata/Europe/Copenhagen.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Europe/Berlin)]} {
LoadTimeZoneFile Europe/Berlin
}
set TZData(:Europe/Copenhagen) $TZData(:Europe/Berlin)
|
Changes to library/tzdata/Europe/Dublin.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Dublin) {
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Dublin) {
{-9223372036854775808 -1521 0 LMT}
{-2821649679 -1521 0 DMT}
{-1691962479 2079 1 IST}
{-1680471279 0 0 GMT}
{-1664143200 3600 1 BST}
{-1650146400 0 0 GMT}
{-1633903200 3600 1 BST}
{-1617487200 0 0 GMT}
{-1601848800 3600 1 BST}
|
| ︙ | ︙ |
Changes to library/tzdata/Europe/Kiev.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Europe/Kyiv)]} {
LoadTimeZoneFile Europe/Kyiv
}
set TZData(:Europe/Kiev) $TZData(:Europe/Kyiv)
|
Added library/tzdata/Europe/Kyiv.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 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 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 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 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 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Kyiv) {
{-9223372036854775808 7324 0 LMT}
{-2840148124 7324 0 KMT}
{-1441159324 7200 0 EET}
{-1247536800 10800 0 MSK}
{-892522800 3600 0 CET}
{-857257200 3600 0 CET}
{-844556400 7200 1 CEST}
{-828226800 3600 0 CET}
{-825382800 10800 0 MSD}
{354920400 14400 1 MSD}
{370728000 10800 0 MSK}
{386456400 14400 1 MSD}
{402264000 10800 0 MSK}
{417992400 14400 1 MSD}
{433800000 10800 0 MSK}
{449614800 14400 1 MSD}
{465346800 10800 0 MSK}
{481071600 14400 1 MSD}
{496796400 10800 0 MSK}
{512521200 14400 1 MSD}
{528246000 10800 0 MSK}
{543970800 14400 1 MSD}
{559695600 10800 0 MSK}
{575420400 14400 1 MSD}
{591145200 10800 0 MSK}
{606870000 14400 1 MSD}
{622594800 10800 0 MSK}
{638319600 14400 1 MSD}
{646786800 10800 1 EEST}
{686102400 7200 0 EET}
{701827200 10800 1 EEST}
{717552000 7200 0 EET}
{733276800 10800 1 EEST}
{749001600 7200 0 EET}
{764726400 10800 1 EEST}
{780451200 7200 0 EET}
{796176000 10800 1 EEST}
{811900800 7200 0 EET}
{828230400 10800 1 EEST}
{831938400 10800 0 EEST}
{846378000 7200 0 EET}
{859683600 10800 1 EEST}
{877827600 7200 0 EET}
{891133200 10800 1 EEST}
{909277200 7200 0 EET}
{922582800 10800 1 EEST}
{941331600 7200 0 EET}
{954032400 10800 1 EEST}
{972781200 7200 0 EET}
{985482000 10800 1 EEST}
{1004230800 7200 0 EET}
{1017536400 10800 1 EEST}
{1035680400 7200 0 EET}
{1048986000 10800 1 EEST}
{1067130000 7200 0 EET}
{1080435600 10800 1 EEST}
{1099184400 7200 0 EET}
{1111885200 10800 1 EEST}
{1130634000 7200 0 EET}
{1143334800 10800 1 EEST}
{1162083600 7200 0 EET}
{1174784400 10800 1 EEST}
{1193533200 7200 0 EET}
{1206838800 10800 1 EEST}
{1224982800 7200 0 EET}
{1238288400 10800 1 EEST}
{1256432400 7200 0 EET}
{1269738000 10800 1 EEST}
{1288486800 7200 0 EET}
{1301187600 10800 1 EEST}
{1319936400 7200 0 EET}
{1332637200 10800 1 EEST}
{1351386000 7200 0 EET}
{1364691600 10800 1 EEST}
{1382835600 7200 0 EET}
{1396141200 10800 1 EEST}
{1414285200 7200 0 EET}
{1427590800 10800 1 EEST}
{1445734800 7200 0 EET}
{1459040400 10800 1 EEST}
{1477789200 7200 0 EET}
{1490490000 10800 1 EEST}
{1509238800 7200 0 EET}
{1521939600 10800 1 EEST}
{1540688400 7200 0 EET}
{1553994000 10800 1 EEST}
{1572138000 7200 0 EET}
{1585443600 10800 1 EEST}
{1603587600 7200 0 EET}
{1616893200 10800 1 EEST}
{1635642000 7200 0 EET}
{1648342800 10800 1 EEST}
{1667091600 7200 0 EET}
{1679792400 10800 1 EEST}
{1698541200 7200 0 EET}
{1711846800 10800 1 EEST}
{1729990800 7200 0 EET}
{1743296400 10800 1 EEST}
{1761440400 7200 0 EET}
{1774746000 10800 1 EEST}
{1792890000 7200 0 EET}
{1806195600 10800 1 EEST}
{1824944400 7200 0 EET}
{1837645200 10800 1 EEST}
{1856394000 7200 0 EET}
{1869094800 10800 1 EEST}
{1887843600 7200 0 EET}
{1901149200 10800 1 EEST}
{1919293200 7200 0 EET}
{1932598800 10800 1 EEST}
{1950742800 7200 0 EET}
{1964048400 10800 1 EEST}
{1982797200 7200 0 EET}
{1995498000 10800 1 EEST}
{2014246800 7200 0 EET}
{2026947600 10800 1 EEST}
{2045696400 7200 0 EET}
{2058397200 10800 1 EEST}
{2077146000 7200 0 EET}
{2090451600 10800 1 EEST}
{2108595600 7200 0 EET}
{2121901200 10800 1 EEST}
{2140045200 7200 0 EET}
{2153350800 10800 1 EEST}
{2172099600 7200 0 EET}
{2184800400 10800 1 EEST}
{2203549200 7200 0 EET}
{2216250000 10800 1 EEST}
{2234998800 7200 0 EET}
{2248304400 10800 1 EEST}
{2266448400 7200 0 EET}
{2279754000 10800 1 EEST}
{2297898000 7200 0 EET}
{2311203600 10800 1 EEST}
{2329347600 7200 0 EET}
{2342653200 10800 1 EEST}
{2361402000 7200 0 EET}
{2374102800 10800 1 EEST}
{2392851600 7200 0 EET}
{2405552400 10800 1 EEST}
{2424301200 7200 0 EET}
{2437606800 10800 1 EEST}
{2455750800 7200 0 EET}
{2469056400 10800 1 EEST}
{2487200400 7200 0 EET}
{2500506000 10800 1 EEST}
{2519254800 7200 0 EET}
{2531955600 10800 1 EEST}
{2550704400 7200 0 EET}
{2563405200 10800 1 EEST}
{2582154000 7200 0 EET}
{2595459600 10800 1 EEST}
{2613603600 7200 0 EET}
{2626909200 10800 1 EEST}
{2645053200 7200 0 EET}
{2658358800 10800 1 EEST}
{2676502800 7200 0 EET}
{2689808400 10800 1 EEST}
{2708557200 7200 0 EET}
{2721258000 10800 1 EEST}
{2740006800 7200 0 EET}
{2752707600 10800 1 EEST}
{2771456400 7200 0 EET}
{2784762000 10800 1 EEST}
{2802906000 7200 0 EET}
{2816211600 10800 1 EEST}
{2834355600 7200 0 EET}
{2847661200 10800 1 EEST}
{2866410000 7200 0 EET}
{2879110800 10800 1 EEST}
{2897859600 7200 0 EET}
{2910560400 10800 1 EEST}
{2929309200 7200 0 EET}
{2942010000 10800 1 EEST}
{2960758800 7200 0 EET}
{2974064400 10800 1 EEST}
{2992208400 7200 0 EET}
{3005514000 10800 1 EEST}
{3023658000 7200 0 EET}
{3036963600 10800 1 EEST}
{3055712400 7200 0 EET}
{3068413200 10800 1 EEST}
{3087162000 7200 0 EET}
{3099862800 10800 1 EEST}
{3118611600 7200 0 EET}
{3131917200 10800 1 EEST}
{3150061200 7200 0 EET}
{3163366800 10800 1 EEST}
{3181510800 7200 0 EET}
{3194816400 10800 1 EEST}
{3212960400 7200 0 EET}
{3226266000 10800 1 EEST}
{3245014800 7200 0 EET}
{3257715600 10800 1 EEST}
{3276464400 7200 0 EET}
{3289165200 10800 1 EEST}
{3307914000 7200 0 EET}
{3321219600 10800 1 EEST}
{3339363600 7200 0 EET}
{3352669200 10800 1 EEST}
{3370813200 7200 0 EET}
{3384118800 10800 1 EEST}
{3402867600 7200 0 EET}
{3415568400 10800 1 EEST}
{3434317200 7200 0 EET}
{3447018000 10800 1 EEST}
{3465766800 7200 0 EET}
{3479072400 10800 1 EEST}
{3497216400 7200 0 EET}
{3510522000 10800 1 EEST}
{3528666000 7200 0 EET}
{3541971600 10800 1 EEST}
{3560115600 7200 0 EET}
{3573421200 10800 1 EEST}
{3592170000 7200 0 EET}
{3604870800 10800 1 EEST}
{3623619600 7200 0 EET}
{3636320400 10800 1 EEST}
{3655069200 7200 0 EET}
{3668374800 10800 1 EEST}
{3686518800 7200 0 EET}
{3699824400 10800 1 EEST}
{3717968400 7200 0 EET}
{3731274000 10800 1 EEST}
{3750022800 7200 0 EET}
{3762723600 10800 1 EEST}
{3781472400 7200 0 EET}
{3794173200 10800 1 EEST}
{3812922000 7200 0 EET}
{3825622800 10800 1 EEST}
{3844371600 7200 0 EET}
{3857677200 10800 1 EEST}
{3875821200 7200 0 EET}
{3889126800 10800 1 EEST}
{3907270800 7200 0 EET}
{3920576400 10800 1 EEST}
{3939325200 7200 0 EET}
{3952026000 10800 1 EEST}
{3970774800 7200 0 EET}
{3983475600 10800 1 EEST}
{4002224400 7200 0 EET}
{4015530000 10800 1 EEST}
{4033674000 7200 0 EET}
{4046979600 10800 1 EEST}
{4065123600 7200 0 EET}
{4078429200 10800 1 EEST}
{4096573200 7200 0 EET}
}
|
Changes to library/tzdata/Europe/Luxembourg.
1 | # created by tools/tclZIC.tcl - do not edit | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Europe/Brussels)]} {
LoadTimeZoneFile Europe/Brussels
}
set TZData(:Europe/Luxembourg) $TZData(:Europe/Brussels)
|
Changes to library/tzdata/Europe/Monaco.
1 | # created by tools/tclZIC.tcl - do not edit | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Europe/Paris)]} {
LoadTimeZoneFile Europe/Paris
}
set TZData(:Europe/Monaco) $TZData(:Europe/Paris)
|
Changes to library/tzdata/Europe/Oslo.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Europe/Berlin)]} {
LoadTimeZoneFile Europe/Berlin
}
set TZData(:Europe/Oslo) $TZData(:Europe/Berlin)
|
Changes to library/tzdata/Europe/Simferopol.
| ︙ | ︙ | |||
34 35 36 37 38 39 40 |
{701042400 7200 0 EET}
{701827200 10800 1 EEST}
{717552000 7200 0 EET}
{733276800 10800 1 EEST}
{749001600 7200 0 EET}
{764726400 10800 1 EEST}
{767743200 14400 0 MSD}
| | | | | | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
{701042400 7200 0 EET}
{701827200 10800 1 EEST}
{717552000 7200 0 EET}
{733276800 10800 1 EEST}
{749001600 7200 0 EET}
{764726400 10800 1 EEST}
{767743200 14400 0 MSD}
{780447600 10800 0 MSK}
{796172400 14400 1 MSD}
{811897200 10800 0 MSK}
{828219600 14400 1 MSD}
{846374400 10800 0 MSK}
{859683600 10800 0 EEST}
{877827600 7200 0 EET}
{891133200 10800 1 EEST}
{909277200 7200 0 EET}
{922582800 10800 1 EEST}
{941331600 7200 0 EET}
{954032400 10800 1 EEST}
|
| ︙ | ︙ |
Changes to library/tzdata/Europe/Stockholm.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Europe/Berlin)]} {
LoadTimeZoneFile Europe/Berlin
}
set TZData(:Europe/Stockholm) $TZData(:Europe/Berlin)
|
Changes to library/tzdata/Iceland.
1 | # created by tools/tclZIC.tcl - do not edit | | | | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Africa/Abidjan)]} {
LoadTimeZoneFile Africa/Abidjan
}
set TZData(:Iceland) $TZData(:Africa/Abidjan)
|
Changes to library/tzdata/Indian/Christmas.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Asia/Bangkok)]} {
LoadTimeZoneFile Asia/Bangkok
}
set TZData(:Indian/Christmas) $TZData(:Asia/Bangkok)
|
Changes to library/tzdata/Indian/Cocos.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Asia/Yangon)]} {
LoadTimeZoneFile Asia/Yangon
}
set TZData(:Indian/Cocos) $TZData(:Asia/Yangon)
|
Changes to library/tzdata/Indian/Kerguelen.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Indian/Maldives)]} {
LoadTimeZoneFile Indian/Maldives
}
set TZData(:Indian/Kerguelen) $TZData(:Indian/Maldives)
|
Changes to library/tzdata/Indian/Mahe.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Asia/Dubai)]} {
LoadTimeZoneFile Asia/Dubai
}
set TZData(:Indian/Mahe) $TZData(:Asia/Dubai)
|
Changes to library/tzdata/Indian/Reunion.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Asia/Dubai)]} {
LoadTimeZoneFile Asia/Dubai
}
set TZData(:Indian/Reunion) $TZData(:Asia/Dubai)
|
Changes to library/tzdata/Pacific/Chuuk.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < < < < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Pacific/Port_Moresby)]} {
LoadTimeZoneFile Pacific/Port_Moresby
}
set TZData(:Pacific/Chuuk) $TZData(:Pacific/Port_Moresby)
|
Changes to library/tzdata/Pacific/Easter.
| ︙ | ︙ | |||
106 107 108 109 110 111 112 |
{1554606000 -21600 0 -06}
{1567915200 -18000 1 -06}
{1586055600 -21600 0 -06}
{1599364800 -18000 1 -06}
{1617505200 -21600 0 -06}
{1630814400 -18000 1 -06}
{1648954800 -21600 0 -06}
| | | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 |
{1554606000 -21600 0 -06}
{1567915200 -18000 1 -06}
{1586055600 -21600 0 -06}
{1599364800 -18000 1 -06}
{1617505200 -21600 0 -06}
{1630814400 -18000 1 -06}
{1648954800 -21600 0 -06}
{1662868800 -18000 1 -06}
{1680404400 -21600 0 -06}
{1693713600 -18000 1 -06}
{1712458800 -21600 0 -06}
{1725768000 -18000 1 -06}
{1743908400 -21600 0 -06}
{1757217600 -18000 1 -06}
{1775358000 -21600 0 -06}
|
| ︙ | ︙ |
Changes to library/tzdata/Pacific/Funafuti.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Pacific/Tarawa)]} {
LoadTimeZoneFile Pacific/Tarawa
}
set TZData(:Pacific/Funafuti) $TZData(:Pacific/Tarawa)
|
Changes to library/tzdata/Pacific/Majuro.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < < < < < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Pacific/Tarawa)]} {
LoadTimeZoneFile Pacific/Tarawa
}
set TZData(:Pacific/Majuro) $TZData(:Pacific/Tarawa)
|
Changes to library/tzdata/Pacific/Pohnpei.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < < < < < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Pacific/Guadalcanal)]} {
LoadTimeZoneFile Pacific/Guadalcanal
}
set TZData(:Pacific/Pohnpei) $TZData(:Pacific/Guadalcanal)
|
Changes to library/tzdata/Pacific/Ponape.
1 | # created by tools/tclZIC.tcl - do not edit | | | | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Pacific/Guadalcanal)]} {
LoadTimeZoneFile Pacific/Guadalcanal
}
set TZData(:Pacific/Ponape) $TZData(:Pacific/Guadalcanal)
|
Changes to library/tzdata/Pacific/Truk.
1 | # created by tools/tclZIC.tcl - do not edit | | | | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Pacific/Port_Moresby)]} {
LoadTimeZoneFile Pacific/Port_Moresby
}
set TZData(:Pacific/Truk) $TZData(:Pacific/Port_Moresby)
|
Changes to library/tzdata/Pacific/Wake.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Pacific/Tarawa)]} {
LoadTimeZoneFile Pacific/Tarawa
}
set TZData(:Pacific/Wake) $TZData(:Pacific/Tarawa)
|
Changes to library/tzdata/Pacific/Wallis.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Pacific/Tarawa)]} {
LoadTimeZoneFile Pacific/Tarawa
}
set TZData(:Pacific/Wallis) $TZData(:Pacific/Tarawa)
|
Changes to library/tzdata/Pacific/Yap.
1 | # created by tools/tclZIC.tcl - do not edit | | | | | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(Pacific/Port_Moresby)]} {
LoadTimeZoneFile Pacific/Port_Moresby
}
set TZData(:Pacific/Yap) $TZData(:Pacific/Port_Moresby)
|
Deleted library/tzdata/US/Pacific-New.
|
| < < < < < |
Changes to macosx/tclMacOSXFCmd.c.
| ︙ | ︙ | |||
340 341 342 343 344 345 346 | } /* * Construct path to resource fork. */ Tcl_DStringInit(&ds); | | | | 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 |
}
/*
* Construct path to resource fork.
*/
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, native, TCL_INDEX_NONE);
Tcl_DStringAppend(&ds, _PATH_RSRCFORKSPEC, TCL_INDEX_NONE);
result = truncate(Tcl_DStringValue(&ds), 0);
if (result != 0) {
/*
* truncate() on a valid resource fork path may fail with a
* permission error in some OS releases, try truncating with
* open() instead:
|
| ︙ | ︙ | |||
455 456 457 458 459 460 461 | } /* * Construct paths to resource forks. */ Tcl_DStringInit(&srcBuf); | | | | | | 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 | } /* * Construct paths to resource forks. */ Tcl_DStringInit(&srcBuf); Tcl_DStringAppend(&srcBuf, src, TCL_INDEX_NONE); Tcl_DStringAppend(&srcBuf, _PATH_RSRCFORKSPEC, TCL_INDEX_NONE); Tcl_DStringInit(&dstBuf); Tcl_DStringAppend(&dstBuf, dst, TCL_INDEX_NONE); Tcl_DStringAppend(&dstBuf, _PATH_RSRCFORKSPEC, TCL_INDEX_NONE); /* * Do the copy. */ result = TclUnixCopyFile(Tcl_DStringValue(&srcBuf), Tcl_DStringValue(&dstBuf), statBufPtr, 1); |
| ︙ | ︙ |
Changes to macosx/tclMacOSXNotify.c.
| ︙ | ︙ | |||
307 308 309 310 311 312 313 |
int mask; /* Mask of desired events: TCL_READABLE,
* etc. */
int readyMask; /* Mask of events that have been seen since
* the last time file handlers were invoked
* for this file. */
Tcl_FileProc *proc; /* Function to call, in the style of
* Tcl_CreateFileHandler. */
| | | 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 |
int mask; /* Mask of desired events: TCL_READABLE,
* etc. */
int readyMask; /* Mask of events that have been seen since
* the last time file handlers were invoked
* for this file. */
Tcl_FileProc *proc; /* Function to call, in the style of
* Tcl_CreateFileHandler. */
void *clientData; /* Argument to pass to proc. */
struct FileHandler *nextPtr;/* Next in list of all files we care about. */
} FileHandler;
/*
* The following structure is what is added to the Tcl event queue when file
* handlers are ready to fire.
*/
|
| ︙ | ︙ | |||
501 502 503 504 505 506 507 | #define CF_TIMEINTERVAL_FOREVER 5.05e8 /* * Static routines defined in this file. */ static void StartNotifierThread(void); | | | 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 | #define CF_TIMEINTERVAL_FOREVER 5.05e8 /* * Static routines defined in this file. */ static void StartNotifierThread(void); static TCL_NORETURN void NotifierThreadProc(void *clientData); static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); static void TimerWakeUp(CFRunLoopTimerRef timer, void *info); static void QueueFileEvents(void *info); static void UpdateWaitingListAndServiceEvents( CFRunLoopObserverRef observer, CFRunLoopActivity activity, void *info); static int OnOffWaitingList(ThreadSpecificData *tsdPtr, |
| ︙ | ︙ | |||
608 609 610 611 612 613 614 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void *
TclpInitNotifier(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#ifdef WEAK_IMPORT_SPINLOCKLOCK
/*
* Initialize support for weakly imported spinlock API.
|
| ︙ | ︙ | |||
864 865 866 867 868 869 870 | * notifier instance. * *---------------------------------------------------------------------- */ void TclpFinalizeNotifier( | | | 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 |
* notifier instance.
*
*----------------------------------------------------------------------
*/
void
TclpFinalizeNotifier(
TCL_UNUSED(void *))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
LOCK_NOTIFIER_INIT;
notifierCount--;
DISABLE_ASL;
|
| ︙ | ︙ | |||
966 967 968 969 970 971 972 | * Signals the notifier condition variable for the specified notifier. * *---------------------------------------------------------------------- */ void TclpAlertNotifier( | | | 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 |
* Signals the notifier condition variable for the specified notifier.
*
*----------------------------------------------------------------------
*/
void
TclpAlertNotifier(
void *clientData)
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
LOCK_NOTIFIER_TSD;
if (tsdPtr->runLoop) {
CFRunLoopSourceSignal(tsdPtr->runLoopSource);
CFRunLoopWakeUp(tsdPtr->runLoop);
|
| ︙ | ︙ | |||
1043 1044 1045 1046 1047 1048 1049 |
*
*----------------------------------------------------------------------
*/
static void
TimerWakeUp(
TCL_UNUSED(CFRunLoopTimerRef),
| | | 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 |
*
*----------------------------------------------------------------------
*/
static void
TimerWakeUp(
TCL_UNUSED(CFRunLoopTimerRef),
TCL_UNUSED(void *))
{
}
/*
*----------------------------------------------------------------------
*
* TclpServiceModeHook --
|
| ︙ | ︙ | |||
1110 1111 1112 1113 1114 1115 1116 |
int fd, /* Handle of stream to watch. */
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. */
Tcl_FileProc *proc, /* Function to call for each selected
* event. */
| | | 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 |
int fd, /* Handle of stream to watch. */
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. */
Tcl_FileProc *proc, /* Function to call for each selected
* event. */
void *clientData) /* Arbitrary data to pass to proc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL);
if (filePtr == NULL) {
filePtr = (FileHandler *) Tcl_Alloc(sizeof(FileHandler));
filePtr->fd = fd;
|
| ︙ | ︙ | |||
1330 1331 1332 1333 1334 1335 1336 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void *
TclpNotifierData(void)
{
return NULL;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1904 1905 1906 1907 1908 1909 1910 |
*----------------------------------------------------------------------
*/
int
TclAsyncNotifier(
int sigNumber, /* Signal number. */
TCL_UNUSED(Tcl_ThreadId), /* Target thread. */
| | | 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 |
*----------------------------------------------------------------------
*/
int
TclAsyncNotifier(
int sigNumber, /* Signal number. */
TCL_UNUSED(Tcl_ThreadId), /* Target thread. */
TCL_UNUSED(void *), /* Notifier data. */
int *flagPtr, /* Flag to mark. */
int value) /* Value of mark. */
{
#if TCL_THREADS
/*
* WARNING:
* This code most likely runs in a signal handler. Thus,
|
| ︙ | ︙ | |||
1963 1964 1965 1966 1967 1968 1969 | * the notifier thread first starts. * *---------------------------------------------------------------------- */ static TCL_NORETURN void NotifierThreadProc( | | | 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 |
* the notifier thread first starts.
*
*----------------------------------------------------------------------
*/
static TCL_NORETURN void
NotifierThreadProc(
TCL_UNUSED(void *))
{
ThreadSpecificData *tsdPtr;
fd_set readableMask, writableMask, exceptionalMask;
int i, ret, numFdBits = 0, polling;
struct timeval poll = {0., 0.}, *timePtr;
char buf[2];
|
| ︙ | ︙ |
Changes to tests-perf/clock.perf.tcl.
| ︙ | ︙ | |||
28 29 30 31 32 33 34 |
namespace eval ::tclTestPerf-TclClock {
namespace path {::tclTestPerf}
## set testing defaults:
set ::env(TCL_TZ) :CET
| | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
namespace eval ::tclTestPerf-TclClock {
namespace path {::tclTestPerf}
## set testing defaults:
set ::env(TCL_TZ) :CET
# warm-up interpreter compiler env, clock platform-related features:
## warm-up test-related features (load clock.tcl, system zones, locales, etc.):
clock scan "" -gmt 1
clock scan ""
clock scan "" -timezone :CET
clock scan "" -format "" -locale en
clock scan "" -format "" -locale de
|
| ︙ | ︙ |
Added tests-perf/comparePerf.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 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 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 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 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 219 220 221 222 223 224 225 226 227 228 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 364 365 366 367 368 369 370 371 |
#!/usr/bin/tclsh
# ------------------------------------------------------------------------
#
# comparePerf.tcl --
#
# Script to compare performance data from multiple runs.
#
# ------------------------------------------------------------------------
#
# See the file "license.terms" for information on usage and redistribution
# of this file.
#
# Usage:
# tclsh comparePerf.tcl [--regexp RE] [--ratio time|rate] [--combine] [--base BASELABEL] PERFFILE ...
#
# The test data from each input file is tabulated so as to compare the results
# of test runs. If a PERFFILE does not exist, it is retried by adding the
# .perf extension. If the --regexp is specified, only test results whose
# id matches RE are examined.
#
# If the --combine option is specified, results of test sets with the same
# label are combined and averaged in the output.
#
# If the --base option is specified, the BASELABEL is used as the label to use
# the base timing. Otherwise, the label of the first data file is used.
#
# If --ratio option is "time" the ratio of test timing vs base test timing
# is shown. If "rate" (default) the inverse is shown.
#
# If --no-header is specified, the header describing test configuration is
# not output.
#
# The format of input files is as follows:
#
# Each line must begin with one of the characters below followed by a space
# followed by a string whose semantics depend on the initial character.
# E - Full path to the Tcl executable that was used to generate the file
# V - The Tcl patchlevel of the implementation
# D - A description for the test run for human consumption
# L - A label used to identify run environment. The --combine option will
# average all measuremets that have the same label. An input file without
# a label is treated as having a unique label and not combined with any other.
# P - A test measurement (see below)
# R - The number of runs made for the each test
# # - A comment, may be an arbitrary string. Usually included in performance
# data to describe the test. This is silently ignored
#
# Any lines not matching one of the above are ignored with a warning to stderr.
#
# A line beginning with the "P" marker is a test measurement. The first word
# following is a floating point number representing the test runtime.
# The remaining line (after trimming of whitespace) is the id of the test.
# Test generators are encouraged to make the id a well-defined machine-parseable
# as well human readable description of the test. The id must not appear more
# than once. An example test measurement line:
# P 2.32280 linsert in unshared L[10000] 1 elems 10000 times at 0 (var)
# Note here the iteration count is not present.
#
namespace eval perf::compare {
# List of dictionaries, one per input file
variable PerfData
}
proc perf::compare::warn {message} {
puts stderr "Warning: $message"
}
proc perf::compare::print {text} {
puts stdout $text
}
proc perf::compare::slurp {testrun_path} {
variable PerfData
set runtimes [dict create]
set path [file normalize $testrun_path]
set fd [open $path]
array set header {}
while {[gets $fd line] >= 0} {
set line [regsub -all {\s+} [string trim $line] " "]
switch -glob -- $line {
"#*" {
# Skip comments
}
"R *" -
"L *" -
"D *" -
"V *" -
"T *" -
"E *" {
set marker [lindex $line 0]
if {[info exists header($marker)]} {
warn "Ignoring $marker record (duplicate): \"$line\""
}
set header($marker) [string range $line 2 end]
}
"P *" {
if {[scan $line "P %f %n" runtime id_start] == 2} {
set id [string range $line $id_start end]
if {[dict exists $runtimes $id]} {
warn "Ignoring duplicate test id \"$id\""
} else {
dict set runtimes $id $runtime
}
} else {
warn "Invalid test result line format: \"$line\""
}
}
default {
puts stderr "Warning: ignoring unrecognized line \"$line\""
}
}
}
close $fd
set result [dict create Input $path Runtimes $runtimes]
foreach {c k} {
L Label
V Version
E Executable
D Description
} {
if {[info exists header($c)]} {
dict set result $k $header($c)
}
}
return $result
}
proc perf::compare::burp {test_sets} {
variable Options
# Print the key for each test run
set header " "
set separator " "
foreach test_set $test_sets {
set test_set_key "\[[incr test_set_num]\]"
if {! $Options(--no-header)} {
print "$test_set_key"
foreach k {Label Executable Version Input Description} {
if {[dict exists $test_set $k]} {
print "$k: [dict get $test_set $k]"
}
}
}
append header $test_set_key $separator
set separator " "; # Expand because later columns have ratio
}
set header [string trimright $header]
if {! $Options(--no-header)} {
print ""
if {$Options(--ratio) eq "rate"} {
set ratio_description "ratio of baseline to the measurement (higher is faster)."
} else {
set ratio_description "ratio of measurement to the baseline (lower is faster)."
}
print "The first column \[1\] is the baseline measurement."
print "Subsequent columns are pairs of the additional measurement and "
print $ratio_description
print ""
}
# Print the actual test run data
print $header
set test_sets [lassign $test_sets base_set]
set fmt {%#10.5f}
set fmt_ratio {%-6.2f}
foreach {id base_runtime} [dict get $base_set Runtimes] {
if {[info exists Options(--regexp)]} {
if {![regexp $Options(--regexp) $id]} {
continue
}
}
if {$Options(--print-test-number)} {
set line "[format %-4s [incr counter].]"
} else {
set line ""
}
append line [format $fmt $base_runtime]
foreach test_set $test_sets {
if {[dict exists $test_set Runtimes $id]} {
set runtime [dict get $test_set Runtimes $id]
if {$Options(--ratio) eq "time"} {
if {$base_runtime != 0} {
set ratio [format $fmt_ratio [expr {$runtime/$base_runtime}]]
} else {
if {$runtime == 0} {
set ratio "NaN "
} else {
set ratio "Inf "
}
}
} else {
if {$runtime != 0} {
set ratio [format $fmt_ratio [expr {$base_runtime/$runtime}]]
} else {
if {$base_runtime == 0} {
set ratio "NaN "
} else {
set ratio "Inf "
}
}
}
append line "|" [format $fmt $runtime] "|" $ratio
} else {
append line [string repeat { } 11]
}
}
append line "|" $id
print $line
}
}
proc perf::compare::chew {test_sets} {
variable Options
# Combine test sets that have the same label, averaging the values
set unlabeled_sets {}
array set labeled_sets {}
foreach test_set $test_sets {
# If there is no label, treat as independent set
if {![dict exists $test_set Label]} {
lappend unlabeled_sets $test_set
} else {
lappend labeled_sets([dict get $test_set Label]) $test_set
}
}
foreach label [array names labeled_sets] {
set combined_set [lindex $labeled_sets($label) 0]
set runtimes [dict get $combined_set Runtimes]
foreach test_set [lrange $labeled_sets($label) 1 end] {
dict for {id timing} [dict get $test_set Runtimes] {
dict lappend runtimes $id $timing
}
}
dict for {id timings} $runtimes {
set total [tcl::mathop::+ {*}$timings]
dict set runtimes $id [expr {$total/[llength $timings]}]
}
dict set combined_set Runtimes $runtimes
set labeled_sets($label) $combined_set
}
# Choose the "base" test set
if {![info exists Options(--base)]} {
set first_set [lindex $test_sets 0]
if {[dict exists $first_set Label]} {
# Use label of first as the base
set Options(--base) [dict get $first_set Label]
}
}
if {[info exists Options(--base)] && $Options(--base) ne ""} {
lappend combined_sets $labeled_sets($Options(--base));# Will error if no such
unset labeled_sets($Options(--base))
} else {
lappend combined_sets [lindex $unlabeled_sets 0]
set unlabeled_sets [lrange $unlabeled_sets 1 end]
}
foreach label [array names labeled_sets] {
lappend combined_sets $labeled_sets($label)
}
lappend combined_sets {*}$unlabeled_sets
return $combined_sets
}
proc perf::compare::setup {argv} {
variable Options
array set Options {
--ratio rate
--combine 0
--print-test-number 0
--no-header 0
}
while {[llength $argv]} {
set argv [lassign $argv arg]
switch -glob -- $arg {
-r -
--regexp {
if {[llength $argv] == 0} {
error "Missing value for option $arg"
}
set argv [lassign $argv val]
set Options(--regexp) $val
}
--ratio {
if {[llength $argv] == 0} {
error "Missing value for option $arg"
}
set argv [lassign $argv val]
if {$val ni {time rate}} {
error "Value for option $arg must be either \"time\" or \"rate\""
}
set Options(--ratio) $val
}
--print-test-number -
--combine -
--no-header {
set Options($arg) 1
}
--base {
if {[llength $argv] == 0} {
error "Missing value for option $arg"
}
set argv [lassign $argv val]
set Options($arg) $val
}
-- {
# Remaining will be passed back to the caller
break
}
--* {
error "Unknown option $arg"
}
-* {
error "Unknown option -[lindex $arg 0]"
}
default {
# Remaining will be passed back to the caller
set argv [linsert $argv 0 $arg]
break;
}
}
}
set paths {}
foreach path $argv {
set path [file join $path]; # Convert from native else glob fails
if {[file isfile $path]} {
lappend paths $path
continue
}
if {[file isfile $path.perf]} {
lappend paths $path.perf
continue
}
lappend paths {*}[glob -nocomplain $path]
}
return $paths
}
proc perf::compare::main {} {
variable Options
set paths [setup $::argv]
if {[llength $paths] == 0} {
error "No test data files specified."
}
set test_data [list ]
set seen [dict create]
foreach path $paths {
if {![dict exists $seen $path]} {
lappend test_data [slurp $path]
dict set seen $path ""
}
}
if {$Options(--combine)} {
set test_data [chew $test_data]
}
burp $test_data
}
perf::compare::main
|
Added tests-perf/listPerf.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 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 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 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 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 219 220 221 222 223 224 225 226 227 228 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 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 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 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 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 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 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 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 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 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 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 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 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 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 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 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 |
#!/usr/bin/tclsh
# ------------------------------------------------------------------------
#
# listPerf.tcl --
#
# This file provides performance tests for list operations.
#
# ------------------------------------------------------------------------
#
# See the file "license.terms" for information on usage and redistribution
# of this file.
#
# Note: this file does not use the test-performance.tcl framework as we want
# more direct control over timerate options.
catch {package require twapi}
namespace eval perf::list {
variable perfScript [file normalize [info script]]
# Test for each of these lengths
variable Lengths {10 100 1000 10000}
variable RunTimes
set RunTimes(command) 0.0
set RunTimes(total) 0.0
variable Options
array set Options {
--print-comments 0
--print-iterations 0
}
# Procs used for calibrating overhead
proc proc2args {a b} {}
proc proc3args {a b c} {}
proc print {s} {
puts $s
}
proc print_usage {} {
puts stderr "Usage: [file tail [info nameofexecutable]] $::argv0 \[options\] \[command ...\]"
puts stderr "\t--description DESC\tHuman readable description of test run"
puts stderr "\t--label LABEL\tA label used to identify test environment"
puts stderr "\t--print-comments\tPrint comment for each test"
puts stderr "\t--print-iterations\tPrint number of iterations run for each test"
}
proc setup {argv} {
variable Options
variable Lengths
while {[llength $argv]} {
set argv [lassign $argv arg]
switch -glob -- $arg {
--print-comments -
--print-iterations {
set Options($arg) 1
}
--label -
--description {
if {[llength $argv] == 0} {
error "Missing value for option $arg"
}
set argv [lassign $argv val]
set Options($arg) $val
}
--lengths {
if {[llength $argv] == 0} {
error "Missing value for option $arg"
}
set argv [lassign $argv val]
set Lengths $val
}
-- {
# Remaining will be passed back to the caller
break
}
--* {
error "Unknown option $arg"
}
default {
# Remaining will be passed back to the caller
set argv [linsert $argv 0 $arg]
break;
}
}
}
return $argv
}
proc format_timings {us iters} {
variable Options
if {!$Options(--print-iterations)} {
return "[format {%#10.4f} $us]"
}
return "[format {%#10.4f} $us] [format {%8d} $iters]"
}
proc measure {id script args} {
variable NullOverhead
variable RunTimes
variable Options
set opts(-overhead) ""
set opts(-runs) 5
while {[llength $args]} {
set args [lassign $args opt]
if {[llength $args] == 0} {
error "No argument supplied for $opt option. Test: $id"
}
set args [lassign $args val]
switch $opt {
-setup -
-cleanup -
-overhead -
-time -
-runs -
-reps {
set opts($opt) $val
}
default {
error "Unknown option $opt. Test: $id"
}
}
}
set timerate_args {}
if {[info exists opts(-time)]} {
lappend timerate_args $opts(-time)
}
if {[info exists opts(-reps)]} {
if {[info exists opts(-time)]} {
set timerate_args [list $opts(-time) $opts(-reps)]
} else {
# Force the default for first time option
set timerate_args [list 1000 $opts(-reps)]
}
} elseif {[info exists opts(-time)]} {
set timerate_args [list $opts(-time)]
}
if {[info exists opts(-setup)]} {
uplevel 1 $opts(-setup)
}
# Cache the empty overhead to prevent unnecessary delays. Note if you modify
# to cache other scripts, the cache key must be AFTER substituting the
# overhead script in the caller's context.
if {$opts(-overhead) eq ""} {
if {![info exists NullOverhead]} {
set NullOverhead [lindex [timerate {}] 0]
}
set overhead_us $NullOverhead
} else {
# The overhead measurements might use setup so we need to setup
# first and then cleanup in preparation for setting up again for
# the script to be measured
if {[info exists opts(-setup)]} {
uplevel 1 $opts(-setup)
}
set overhead_us [lindex [uplevel 1 [list timerate $opts(-overhead)]] 0]
if {[info exists opts(-cleanup)]} {
uplevel 1 $opts(-cleanup)
}
}
set timings {}
for {set i 0} {$i < $opts(-runs)} {incr i} {
if {[info exists opts(-setup)]} {
uplevel 1 $opts(-setup)
}
lappend timings [uplevel 1 [list timerate -overhead $overhead_us $script {*}$timerate_args]]
if {[info exists opts(-cleanup)]} {
uplevel 1 $opts(-cleanup)
}
}
set timings [lsort -real -index 0 $timings]
if {$opts(-runs) > 15} {
set ignore [expr {$opts(-runs)/8}]
} elseif {$opts(-runs) >= 5} {
set ignore 2
} else {
set ignore 0
}
# Ignore highest and lowest
set timings [lrange $timings 0 end-$ignore]
# Average it out
set us 0
set iters 0
foreach timing $timings {
set us [expr {$us + [lindex $timing 0]}]
set iters [expr {$iters + [lindex $timing 2]}]
}
set us [expr {$us/[llength $timings]}]
set iters [expr {$iters/[llength $timings]}]
set RunTimes(command) [expr {$RunTimes(command) + $us}]
print "P [format_timings $us $iters] $id"
}
proc comment {args} {
variable Options
if {$Options(--print-comments)} {
print "# [join $args { }]"
}
}
proc spanned_list {len} {
# Note - for small len, this will not create a spanned list
set delta [expr {$len/8}]
return [lrange [lrepeat [expr {$len+(2*$delta)}] a] $delta [expr {$delta+$len-1}]]
}
proc print_separator {command} {
comment [string repeat = 80]
comment Command: $command
}
oo::class create ListPerf {
constructor {args} {
my variable Opts
# Note default Opts can be overridden in construct as well as in measure
set Opts [dict merge {
-setup {
set L [lrepeat $len a]
set Lspan [perf::list::spanned_list $len]
} -cleanup {
unset -nocomplain L
unset -nocomplain Lspan
unset -nocomplain L2
}
} $args]
}
method measure {comment script locals args} {
my variable Opts
dict with locals {}
::perf::list::measure $comment $script {*}[dict merge $Opts $args]
}
method option {opt val} {
my variable Opts
dict set Opts $opt $val
}
method option_unset {opt} {
my variable Opts
unset -nocomplain Opts($opt)
}
}
proc linsert_describe {share_mode len at num iters} {
return "linsert L\[$len\] $share_mode $num elems $iters times at $at"
}
proc linsert_perf {} {
variable Lengths
print_separator linsert
ListPerf create perf -overhead {set L {}} -time 1000
# Note: Const indices take different path through bytecode than variable
# indices hence separate cases below
# Var case
foreach share_mode {shared unshared} {
set idx 0
if {$share_mode eq "shared"} {
comment == Insert into empty lists
comment Insert one element into empty list
measure [linsert_describe shared 0 "0 (var)" 1 1] {linsert $L $idx ""} -setup {set idx 0; set L {}}
} else {
comment == Insert into empty lists
comment Insert one element into empty list
measure [linsert_describe unshared 0 "0 (var)" 1 1] {linsert {} $idx ""} -setup {set idx 0}
}
foreach idx_str [list 0 1 mid end-1 end] {
foreach len $Lengths {
if {$idx_str eq "mid"} {
set idx [expr {$len/2}]
} else {
set idx $idx_str
}
# perf option -reps $reps
set reps 1000
if {$share_mode eq "shared"} {
comment Insert once to shared list with variable index
perf measure [linsert_describe shared $len "$idx (var)" 1 1] \
{linsert $L $idx x} [list len $len idx $idx] -overhead {} -reps 100000
comment Insert multiple times to shared list with variable index
perf measure [linsert_describe shared $len "$idx (var)" 1 $reps] {
set L [linsert $L $idx X]
} [list len $len idx $idx] -reps $reps
comment Insert multiple items multiple times to shared list with variable index
perf measure [linsert_describe shared $len "$idx (var)" 5 $reps] {
set L [linsert $L $idx X X X X X]
} [list len $len idx $idx] -reps $reps
} else {
# NOTE : the Insert once case is left out for unshared lists
# because it requires re-init on every iteration resulting
# in a lot of measurement noise
comment Insert multiple times to unshared list with variable index
perf measure [linsert_describe unshared $len "$idx (var)" 1 $reps] {
set L [linsert $L[set L {}] $idx X]
} [list len $len idx $idx] -reps $reps
comment Insert multiple items multiple times to unshared list with variable index
perf measure [linsert_describe unshared $len "$idx (var)" 5 $reps] {
set L [linsert $L[set L {}] $idx X X X X X]
} [list len $len idx $idx] -reps $reps
}
}
}
}
# Const index
foreach share_mode {shared unshared} {
if {$share_mode eq "shared"} {
comment == Insert into empty lists
comment Insert one element into empty list
measure [linsert_describe shared 0 "0 (const)" 1 1] {linsert $L 0 ""} -setup {set L {}}
} else {
comment == Insert into empty lists
comment Insert one element into empty list
measure [linsert_describe unshared 0 "0 (const)" 1 1] {linsert {} 0 ""}
}
foreach idx_str [list 0 1 mid end end-1] {
foreach len $Lengths {
# Note end, end-1 explicitly calculated as otherwise they
# are not treated as const
if {$idx_str eq "mid"} {
set idx [expr {$len/2}]
} elseif {$idx_str eq "end"} {
set idx [expr {$len-1}]
} elseif {$idx_str eq "end-1"} {
set idx [expr {$len-2}]
} else {
set idx $idx_str
}
#perf option -reps $reps
set reps 100
if {$share_mode eq "shared"} {
comment Insert once to shared list with const index
perf measure [linsert_describe shared $len "$idx (const)" 1 1] \
"linsert \$L $idx x" [list len $len] -overhead {} -reps 10000
comment Insert multiple times to shared list with const index
perf measure [linsert_describe shared $len "$idx (const)" 1 $reps] \
"set L \[linsert \$L $idx X\]" [list len $len] -reps $reps
comment Insert multiple items multiple times to shared list with const index
perf measure [linsert_describe shared $len "$idx (const)" 5 $reps] \
"set L \[linsert \$L $idx X X X X X\]" [list len $len] -reps $reps
} else {
comment Insert multiple times to unshared list with const index
perf measure [linsert_describe unshared $len "$idx (const)" 1 $reps] \
"set L \[linsert \$L\[set L {}\] $idx X]" [list len $len] -reps $reps
comment Insert multiple items multiple times to unshared list with const index
perf measure [linsert_describe unshared $len "$idx (const)" 5 $reps] \
"set L \[linsert \$L\[set L {}\] $idx X X X X X]" [list len $len] -reps $reps
}
}
}
}
# Note: no span tests because the inserts above will themselves create
# spanned lists
perf destroy
}
proc list_describe {len text} {
return "list L\[$len\] $text"
}
proc list_perf {} {
variable Lengths
print_separator list
ListPerf create perf
foreach len $Lengths {
set s [join [lrepeat $len x]]
comment Create a list from a string
perf measure [list_describe $len "from a string"] {list $s} [list s $s len $len]
}
foreach len $Lengths {
comment Create a list from expansion - single list (special optimal case)
perf measure [list_describe $len "from a {*}list"] {list {*}$L} [list len $len]
comment Create a list from two lists - real test of expansion speed
perf measure [list_describe $len "from a {*}list {*}list"] {list {*}$L {*}$L} [list len [expr {$len/2}]]
}
}
proc lappend_describe {share_mode len num iters} {
return "lappend L\[$len\] $share_mode $num elems $iters times"
}
proc lappend_perf {} {
variable Lengths
print_separator lappend
ListPerf create perf -setup {set L [lrepeat [expr {$len/4}] x]}
# Shared
foreach len $Lengths {
comment Append to a shared list variable multiple times
perf measure [lappend_describe shared [expr {$len/2}] 1 $len] {
set L2 $L; # Make shared
lappend L x
} [list len $len] -reps $len -overhead {set L2 $L}
}
# Unshared
foreach len $Lengths {
comment Append to a unshared list variable multiple times
perf measure [lappend_describe unshared [expr {$len/2}] 1 $len] {
lappend L x
} [list len $len] -reps $len
}
# Span
foreach len $Lengths {
comment Append to a unshared-span list variable multiple times
perf measure [lappend_describe unshared-span [expr {$len/2}] 1 $len] {
lappend Lspan x
} [list len $len] -reps $len
}
perf destroy
}
proc lpop_describe {share_mode len at reps} {
return "lpop L\[$len\] $share_mode at $at $reps times"
}
proc lpop_perf {} {
variable Lengths
print_separator lpop
ListPerf create perf
# Shared
perf option -overhead {set L2 $L}
foreach len $Lengths {
set reps [expr {($len >= 1000 ? ($len/2) : $len) - 2}]
foreach idx {0 1 end-1 end} {
comment Pop element at position $idx from a shared list variable
perf measure [lpop_describe shared $len $idx $reps] {
set L2 $L
lpop L $idx
} [list len $len idx $idx] -reps $reps
}
}
# Unshared
perf option -overhead {}
foreach len $Lengths {
set reps [expr {($len >= 1000 ? ($len/2) : $len) - 2}]
foreach idx {0 1 end-1 end} {
comment Pop element at position $idx from an unshared list variable
perf measure [lpop_describe unshared $len $idx $reps] {
lpop L $idx
} [list len $len idx $idx] -reps $reps
}
}
perf destroy
# Nested
ListPerf create perf -setup {
set L [lrepeat $len [list a b]]
}
# Shared, nested index
perf option -overhead {set L2 $L; set L L2}
foreach len $Lengths {
set reps [expr {($len >= 1000 ? ($len/2) : $len) - 2}]
foreach idx {0 1 end-1 end} {
perf measure [lpop_describe shared $len "{$idx 0}" $reps] {
set L2 $L
lpop L $idx 0
set L $L2
} [list len $len idx $idx] -reps $reps
}
}
# TODO - Nested Unshared
# Not sure how to measure performance. When unshared there is no copy
# so deleting a nested index repeatedly is not feasible
perf destroy
}
proc lassign_describe {share_mode len num reps} {
return "lassign L\[$len\] $share_mode $num elems $reps times"
}
proc lassign_perf {} {
variable Lengths
print_separator lassign
ListPerf create perf
foreach share_mode {shared unshared} {
foreach len $Lengths {
if {$share_mode eq "shared"} {
set reps 1000
comment Reflexive lassign - shared
perf measure [lassign_describe shared $len 1 $reps] {
set L2 $L
set L2 [lassign $L2 v]
} [list len $len] -overhead {set L2 $L} -reps $reps
comment Reflexive lassign - shared, multiple
perf measure [lassign_describe shared $len 5 $reps] {
set L2 $L
set L2 [lassign $L2 a b c d e]
} [list len $len] -overhead {set L2 $L} -reps $reps
} else {
set reps [expr {($len >= 1000 ? ($len/2) : $len) - 2}]
comment Reflexive lassign - unshared
perf measure [lassign_describe unshared $len 1 $reps] {
set L [lassign $L v]
} [list len $len] -reps $reps
}
}
}
perf destroy
}
proc lrepeat_describe {len num} {
return "lrepeat L\[$len\] $num elems at a time"
}
proc lrepeat_perf {} {
variable Lengths
print_separator lrepeat
ListPerf create perf -reps 100000
foreach len $Lengths {
comment Generate a list from a single repeated element
perf measure [lrepeat_describe $len 1] {
lrepeat $len a
} [list len $len]
comment Generate a list from multiple repeated elements
perf measure [lrepeat_describe $len 5] {
lrepeat $len a b c d e
} [list len $len]
}
perf destroy
}
proc lreverse_describe {share_mode len} {
return "lreverse L\[$len\] $share_mode"
}
proc lreverse_perf {} {
variable Lengths
print_separator lreverse
ListPerf create perf -reps 10000
foreach share_mode {shared unshared} {
foreach len $Lengths {
if {$share_mode eq "shared"} {
comment Reverse a shared list
perf measure [lreverse_describe shared $len] {
lreverse $L
} [list len $len]
if {$len > 100} {
comment Reverse a shared-span list
perf measure [lreverse_describe shared-span $len] {
lreverse $Lspan
} [list len $len]
}
} else {
comment Reverse a unshared list
perf measure [lreverse_describe unshared $len] {
set L [lreverse $L[set L {}]]
} [list len $len] -overhead {set L $L; set L {}}
if {$len >= 100} {
comment Reverse a unshared-span list
perf measure [lreverse_describe unshared-span $len] {
set Lspan [lreverse $Lspan[set Lspan {}]]
} [list len $len] -overhead {set Lspan $Lspan; set Lspan {}}
}
}
}
}
perf destroy
}
proc llength_describe {share_mode len} {
return "llength L\[$len\] $share_mode"
}
proc llength_perf {} {
variable Lengths
print_separator llength
ListPerf create perf -reps 100000
foreach len $Lengths {
comment Length of a list
perf measure [llength_describe shared $len] {
llength $L
} [list len $len]
if {$len >= 100} {
comment Length of a span list
perf measure [llength_describe shared-span $len] {
llength $Lspan
} [list len $len]
}
}
perf destroy
}
proc lindex_describe {share_mode len at} {
return "lindex L\[$len\] $share_mode at $at"
}
proc lindex_perf {} {
variable Lengths
print_separator lindex
ListPerf create perf -reps 100000
foreach len $Lengths {
comment Index into a list
set idx [expr {$len/2}]
perf measure [lindex_describe shared $len $idx] {
lindex $L $idx
} [list len $len idx $idx]
if {$len >= 100} {
comment Index into a span list
perf measure [lindex_describe shared-span $len $idx] {
lindex $Lspan $idx
} [list len $len idx $idx]
}
}
perf destroy
}
proc lrange_describe {share_mode len range} {
return "lrange L\[$len\] $share_mode range $range"
}
proc lrange_perf {} {
variable Lengths
print_separator lrange
ListPerf create perf -time 1000 -reps 100000
foreach share_mode {shared unshared} {
foreach len $Lengths {
set eighth [expr {$len/8}]
set ranges [list \
[list 0 0] [list 0 end-1] \
[list $eighth [expr {3*$eighth}]] \
[list $eighth [expr {7*$eighth}]] \
[list 1 end] [list end-1 end] \
]
foreach range $ranges {
comment Range $range in $share_mode list of length $len
if {$share_mode eq "shared"} {
perf measure [lrange_describe shared $len $range] \
"lrange \$L $range" [list len $len range $range]
} else {
perf measure [lrange_describe unshared $len $range] \
"lrange \[lrepeat \$len\ a] $range" \
[list len $len range $range] -overhead {lrepeat $len a}
}
}
if {$len >= 100} {
foreach range $ranges {
comment Range $range in ${share_mode}-span list of length $len
if {$share_mode eq "shared"} {
perf measure [lrange_describe shared-span $len $range] \
"lrange \$Lspan {*}$range" [list len $len range $range]
} else {
perf measure [lrange_describe unshared-span $len $range] \
"lrange \[perf::list::spanned_list \$len\] $range" \
[list len $len range $range] -overhead {perf::list::spanned_list $len}
}
}
}
}
}
perf destroy
}
proc lset_describe {share_mode len at} {
return "lset L\[$len\] $share_mode at $at"
}
proc lset_perf {} {
variable Lengths
print_separator lset
ListPerf create perf -reps 10000
# Shared
foreach share_mode {shared unshared} {
foreach len $Lengths {
foreach idx {0 1 end-1 end end+1} {
comment lset at position $idx in a $share_mode list variable
if {$share_mode eq "shared"} {
perf measure [lset_describe shared $len $idx] {
set L2 $L
lset L $idx X
} [list len $len idx $idx] -overhead {set L2 $L}
} else {
perf measure [lset_describe unshared $len $idx] {
lset L $idx X
} [list len $len idx $idx]
}
}
}
}
perf destroy
# Nested
ListPerf create perf -setup {
set L [lrepeat $len [list a b]]
}
foreach share_mode {shared unshared} {
foreach len $Lengths {
foreach idx {0 1 end-1 end} {
comment lset at position $idx in a $share_mode list variable
if {$share_mode eq "shared"} {
perf measure [lset_describe shared $len "{$idx 0}"] {
set L2 $L
lset L $idx 0 X
} [list len $len idx $idx] -overhead {set L2 $L}
} else {
perf measure [lset_describe unshared $len "{$idx 0}"] {
lset L $idx 0 {X Y}
} [list len $len idx $idx]
}
}
}
}
perf destroy
}
proc lremove_describe {share_mode len at nremoved} {
return "lremove L\[$len\] $share_mode $nremoved elements at $at"
}
proc lremove_perf {} {
variable Lengths
print_separator lremove
ListPerf create perf -reps 10000
foreach share_mode {shared unshared} {
foreach len $Lengths {
foreach idx [list 0 1 [expr {$len/2}] end-1 end] {
if {$share_mode eq "shared"} {
comment Remove one element from shared list
perf measure [lremove_describe shared $len $idx 1] \
{lremove $L $idx} [list len $len idx $idx]
} else {
comment Remove one element from unshared list
set reps [expr {$len >= 1000 ? ($len/8) : ($len-2)}]
perf measure [lremove_describe unshared $len $idx 1] \
{set L [lremove $L[set L {}] $idx]} [list len $len idx $idx] \
-overhead {set L $L; set L {}} -reps $reps
}
}
if {$share_mode eq "shared"} {
comment Remove multiple elements from shared list
perf measure [lremove_describe shared $len [list 0 1 [expr {$len/2}] end-1 end] 5] {
lremove $L 0 1 [expr {$len/2}] end-1 end
} [list len $len]
}
}
# Span
foreach len $Lengths {
foreach idx [list 0 1 [expr {$len/2}] end-1 end] {
if {$share_mode eq "shared"} {
comment Remove one element from shared-span list
perf measure [lremove_describe shared-span $len $idx 1] \
{lremove $Lspan $idx} [list len $len idx $idx]
} else {
comment Remove one element from unshared-span list
set reps [expr {$len >= 1000 ? ($len/8) : ($len-2)}]
perf measure [lremove_describe unshared-span $len $idx 1] \
{set Lspan [lremove $Lspan[set Lspan {}] $idx]} [list len $len idx $idx] \
-overhead {set Lspan $Lspan; set Lspan {}} -reps $reps
}
}
if {$share_mode eq "shared"} {
comment Remove multiple elements from shared-span list
perf measure [lremove_describe shared-span $len [list 0 1 [expr {$len/2}] end-1 end] 5] {
lremove $Lspan 0 1 [expr {$len/2}] end-1 end
} [list len $len]
}
}
}
perf destroy
}
proc lreplace_describe {share_mode len first last ninsert {times 1}} {
if {$last < $first} {
return "lreplace L\[$len\] $share_mode 0 ($first:$last) elems at $first with $ninsert elems $times times."
}
return "lreplace L\[$len\] $share_mode $first:$last with $ninsert elems $times times."
}
proc lreplace_perf {} {
variable Lengths
print_separator lreplace
set default_reps 10000
ListPerf create perf -reps $default_reps
foreach share_mode {shared unshared} {
# Insert only
foreach len $Lengths {
set reps [expr {$len <= 100 ? ($len-2) : ($len/8)}]
foreach first [list 0 1 [expr {$len/2}] end-1 end] {
if {$share_mode eq "shared"} {
comment Insert one to shared list
perf measure [lreplace_describe shared $len $first -1 1] {
lreplace $L $first -1 x
} [list len $len first $first]
comment Insert multiple to shared list
perf measure [lreplace_describe shared $len $first -1 10] {
lreplace $L $first -1 X X X X X X X X X X
} [list len $len first $first]
comment Insert one to shared list repeatedly
perf measure [lreplace_describe shared $len $first -1 1 $reps] {
set L [lreplace $L $first -1 x]
} [list len $len first $first] -reps $reps
comment Insert multiple to shared list repeatedly
perf measure [lreplace_describe shared $len $first -1 10 $reps] {
set L [lreplace $L $first -1 X X X X X X X X X X]
} [list len $len first $first] -reps $reps
} else {
comment Insert one to unshared list
perf measure [lreplace_describe unshared $len $first -1 1] {
set L [lreplace $L[set L {}] $first -1 x]
} [list len $len first $first] -overhead {
set L $L; set L {}
} -reps $reps
comment Insert multiple to unshared list
perf measure [lreplace_describe unshared $len $first -1 10] {
set L [lreplace $L[set L {}] $first -1 X X X X X X X X X X]
} [list len $len first $first] -overhead {
set L $L; set L {}
} -reps $reps
}
}
}
# Delete only
foreach len $Lengths {
set reps [expr {$len <= 100 ? ($len-2) : ($len/8)}]
foreach first [list 0 1 [expr {$len/2}] end-1 end] {
if {$share_mode eq "shared"} {
comment Delete one from shared list
perf measure [lreplace_describe shared $len $first $first 0] {
lreplace $L $first $first
} [list len $len first $first]
} else {
comment Delete one from unshared list
perf measure [lreplace_describe unshared $len $first $first 0] {
set L [lreplace $L[set L {}] $first $first x]
} [list len $len first $first] -overhead {
set L $L; set L {}
} -reps $reps
}
}
}
# Insert + delete
foreach len $Lengths {
set reps [expr {$len <= 100 ? ($len-2) : ($len/8)}]
foreach range [list {0 1} {1 2} {end-2 end-1} {end-1 end}] {
lassign $range first last
if {$share_mode eq "shared"} {
comment Insertions more than deletions from shared list
perf measure [lreplace_describe shared $len $first $last 3] {
lreplace $L $first $last X Y Z
} [list len $len first $first last $last]
comment Insertions same as deletions from shared list
perf measure [lreplace_describe shared $len $first $last 2] {
lreplace $L $first $last X Y
} [list len $len first $first last $last]
comment Insertions fewer than deletions from shared list
perf measure [lreplace_describe shared $len $first $last 1] {
lreplace $L $first $last X
} [list len $len first $first last $last]
} else {
comment Insertions more than deletions from unshared list
perf measure [lreplace_describe unshared $len $first $last 3] {
set L [lreplace $L[set L {}] $first $last X Y Z]
} [list len $len first $first last $last] -overhead {
set L $L; set L {}
} -reps $reps
comment Insertions same as deletions from unshared list
perf measure [lreplace_describe unshared $len $first $last 2] {
set L [lreplace $L[set L {}] $first $last X Y ]
} [list len $len first $first last $last] -overhead {
set L $L; set L {}
} -reps $reps
comment Insertions fewer than deletions from unshared list
perf measure [lreplace_describe unshared $len $first $last 1] {
set L [lreplace $L[set L {}] $first $last X]
} [list len $len first $first last $last] -overhead {
set L $L; set L {}
} -reps $reps
}
}
}
# Spanned Insert + delete
foreach len $Lengths {
set reps [expr {$len <= 100 ? ($len-2) : ($len/8)}]
foreach range [list {0 1} {1 2} {end-2 end-1} {end-1 end}] {
lassign $range first last
if {$share_mode eq "shared"} {
comment Insertions more than deletions from shared-span list
perf measure [lreplace_describe shared-span $len $first $last 3] {
lreplace $Lspan $first $last X Y Z
} [list len $len first $first last $last]
comment Insertions same as deletions from shared-span list
perf measure [lreplace_describe shared-span $len $first $last 2] {
lreplace $Lspan $first $last X Y
} [list len $len first $first last $last]
comment Insertions fewer than deletions from shared-span list
perf measure [lreplace_describe shared-span $len $first $last 1] {
lreplace $Lspan $first $last X
} [list len $len first $first last $last]
} else {
comment Insertions more than deletions from unshared-span list
perf measure [lreplace_describe unshared-span $len $first $last 3] {
set Lspan [lreplace $Lspan[set Lspan {}] $first $last X Y Z]
} [list len $len first $first last $last] -overhead {
set Lspan $Lspan; set Lspan {}
} -reps $reps
comment Insertions same as deletions from unshared-span list
perf measure [lreplace_describe unshared-span $len $first $last 2] {
set Lspan [lreplace $Lspan[set Lspan {}] $first $last X Y ]
} [list len $len first $first last $last] -overhead {
set Lspan $Lspan; set Lspan {}
} -reps $reps
comment Insertions fewer than deletions from unshared-span list
perf measure [lreplace_describe unshared-span $len $first $last 1] {
set Lspan [lreplace $Lspan[set Lspan {}] $first $last X]
} [list len $len first $first last $last] -overhead {
set Lspan $Lspan; set Lspan {}
} -reps $reps
}
}
}
}
perf destroy
}
proc split_describe {len} {
return "split L\[$len\]"
}
proc split_perf {} {
variable Lengths
print_separator split
ListPerf create perf -setup {set S [string repeat "x " $len]}
foreach len $Lengths {
comment Split a string
perf measure [split_describe $len] {
split $S " "
} [list len $len]
}
}
proc join_describe {share_mode len} {
return "join L\[$len\] $share_mode"
}
proc join_perf {} {
variable Lengths
print_separator join
ListPerf create perf -reps 10000
foreach len $Lengths {
comment Join a list
perf measure [join_describe shared $len] {
join $L
} [list len $len]
}
foreach len $Lengths {
comment Join a spanned list
perf measure [join_describe shared-span $len] {
join $Lspan
} [list len $len]
}
perf destroy
}
proc lsearch_describe {share_mode len} {
return "lsearch L\[$len\] $share_mode"
}
proc lsearch_perf {} {
variable Lengths
print_separator lsearch
ListPerf create perf -reps 100000
foreach len $Lengths {
comment Search a list
perf measure [lsearch_describe shared $len] {
lsearch $L needle
} [list len $len]
}
foreach len $Lengths {
comment Search a spanned list
perf measure [lsearch_describe shared-span $len] {
lsearch $Lspan needle
} [list len $len]
}
perf destroy
}
proc foreach_describe {share_mode len} {
return "foreach L\[$len\] $share_mode"
}
proc foreach_perf {} {
variable Lengths
print_separator foreach
ListPerf create perf -reps 10000
foreach len $Lengths {
comment Iterate through a list
perf measure [foreach_describe shared $len] {
foreach e $L {}
} [list len $len]
}
foreach len $Lengths {
comment Iterate a spanned list
perf measure [foreach_describe shared-span $len] {
foreach e $Lspan {}
} [list len $len]
}
perf destroy
}
proc lmap_describe {share_mode len} {
return "lmap L\[$len\] $share_mode"
}
proc lmap_perf {} {
variable Lengths
print_separator lmap
ListPerf create perf -reps 10000
foreach len $Lengths {
comment Iterate through a list
perf measure [lmap_describe shared $len] {
lmap e $L {}
} [list len $len]
}
foreach len $Lengths {
comment Iterate a spanned list
perf measure [lmap_describe shared-span $len] {
lmap e $Lspan {}
} [list len $len]
}
perf destroy
}
proc get_sort_sample {{spanned 0}} {
variable perfScript
variable sortSampleText
if {![info exists sortSampleText]} {
set fd [open $perfScript]
set sortSampleText [split [read $fd] ""]
close $fd
}
set sortSampleText [string range $sortSampleText 0 9999]
# NOTE: do NOT cache list result in a variable as we need it unshared
if {$spanned} {
return [lrange [split $sortSampleText ""] 1 end-1]
} else {
return [split $sortSampleText ""]
}
}
proc lsort_describe {share_mode len} {
return "lsort L\[$len] $share_mode"
}
proc lsort_perf {} {
print_separator lsort
ListPerf create perf -setup {}
comment Sort a shared list
perf measure [lsort_describe shared [llength [perf::list::get_sort_sample]]] {
lsort $L
} {} -setup {set L [perf::list::get_sort_sample]}
comment Sort a shared-span list
perf measure [lsort_describe shared-span [llength [perf::list::get_sort_sample 1]]] {
lsort $L
} {} -setup {set L [perf::list::get_sort_sample 1]}
comment Sort an unshared list
perf measure [lsort_describe unshared [llength [perf::list::get_sort_sample]]] {
lsort [perf::list::get_sort_sample]
} {} -overhead {perf::list::get_sort_sample}
comment Sort an unshared-span list
perf measure [lsort_describe unshared-span [llength [perf::list::get_sort_sample 1]]] {
lsort [perf::list::get_sort_sample 1]
} {} -overhead {perf::list::get_sort_sample 1}
perf destroy
}
proc concat_describe {canonicality len elemlen} {
return "concat L\[$len\] $canonicality with elements of length $elemlen"
}
proc concat_perf {} {
variable Lengths
print_separator concat
ListPerf create perf -reps 100000
foreach len $Lengths {
foreach elemlen {1 100} {
comment Pure lists (no string representation)
perf measure [concat_describe "pure lists" $len $elemlen] {
concat $L $L
} [list len $len elemlen $elemlen] -setup {
set L [lrepeat $len [string repeat a $elemlen]]
}
comment Canonical lists (with string representation)
perf measure [concat_describe "canonical lists" $len $elemlen] {
concat $L $L
} [list len $len elemlen $elemlen] -setup {
set L [lrepeat $len [string repeat a $elemlen]]
append x x $L; # Generate string while keeping internal rep list
unset x
}
comment Non-canonical lists
perf measure [concat_describe "non-canonical lists" $len $elemlen] {
concat $L $L
} [list len $len elemlen $elemlen] -setup {
set L [string repeat "[string repeat a $elemlen] " $len]
llength $L
}
}
}
# Span version
foreach len $Lengths {
foreach elemlen {1 100} {
comment Pure span lists (no string representation)
perf measure [concat_describe "pure spanned lists" $len $elemlen] {
concat $L $L
} [list len $len elemlen $elemlen] -setup {
set L [lrange [lrepeat [expr {$len+2}] [string repeat a $elemlen]] 1 end-1]
}
comment Canonical span lists (with string representation)
perf measure [concat_describe "canonical spanned lists" $len $elemlen] {
concat $L $L
} [list len $len elemlen $elemlen] -setup {
set L [lrange [lrepeat [expr {$len+2}] [string repeat a $elemlen]] 1 end-1]
append x x $L; # Generate string while keeping internal rep list
unset x
}
}
}
perf destroy
}
proc test {} {
variable RunTimes
variable Options
set selections [perf::list::setup $::argv]
if {[llength $selections] == 0} {
set commands [info commands ::perf::list::*_perf]
} else {
set commands [lmap sel $selections {
if {$sel eq "help"} {
print_usage
continue
}
set cmd ::perf::list::${sel}_perf
if {$cmd ni [info commands ::perf::list::*_perf]} {
puts stderr "Error: command $sel is not known or supported. Skipping."
continue
}
set cmd
}]
}
comment Setting up
timerate -calibrate {}
if {[info exists Options(--label)]} {
print "L $Options(--label)"
}
print "V [info patchlevel]"
print "E [info nameofexecutable]"
if {[info exists Options(--description)]} {
print "D $Options(--description)"
}
set twapi_keys {-privatebytes -workingset -workingsetpeak}
if {[info commands ::twapi::get_process_memory_info] ne ""} {
set twapi_vm_pre [::twapi::get_process_memory_info]
}
foreach cmd [lsort -dictionary $commands] {
set RunTimes(command) 0.0
$cmd
set RunTimes(total) [expr {$RunTimes(total)+$RunTimes(command)}]
print "P [format_timings $RunTimes(command) 1] [string range $cmd 14 end-5] total run time"
}
# Print total runtime in same format as timerate output
print "P [format_timings $RunTimes(total) 1] Total run time"
if {[info exists twapi_vm_pre]} {
set twapi_vm_post [::twapi::get_process_memory_info]
set MB 1048576.0
foreach key $twapi_keys {
set pre [expr {[dict get $twapi_vm_pre $key]/$MB}]
set post [expr {[dict get $twapi_vm_post $key]/$MB}]
print "P [format_timings $pre 1] Memory (MB) $key pre-test"
print "P [format_timings $post 1] Memory (MB) $key post-test"
print "P [format_timings [expr {$post-$pre}] 1] Memory (MB) delta $key"
}
}
if {[info commands memory] ne ""} {
foreach line [split [memory info] \n] {
if {$line eq ""} continue
set line [split $line]
set val [expr {[lindex $line end]/1000.0}]
set line [string trim [join [lrange $line 0 end-1]]]
print "P [format_timings $val 1] memdbg $line (in thousands)"
}
print "# Allocations not freed on exit written to the lost-memory.tmp file."
print "# These will have to be manually compared."
# env TCL_FINALIZE_ON_EXIT must be set to 1 for this.
# DO NOT SET HERE - set ::env(TCL_FINALIZE_ON_EXIT) 1
# Must be set in environment before starting tclsh else bogus results
if {[info exists Options(--label)]} {
set dump_file list-memory-$Options(--label).memdmp
} else {
set dump_file list-memory-[pid].memdmp
}
memory onexit $dump_file
}
}
}
if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} {
::perf::list::test
}
|
Changes to tests-perf/test-performance.tcl.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 |
# Copyright © 2014 Serg G. Brester (aka sebres)
#
# See the file "license.terms" for information on usage and redistribution
# of this file.
#
namespace eval ::tclTestPerf {
| | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# Copyright © 2014 Serg G. Brester (aka sebres)
#
# See the file "license.terms" for information on usage and redistribution
# of this file.
#
namespace eval ::tclTestPerf {
# warm-up interpreter compiler env, calibrate timerate measurement functionality:
# if no timerate here - import from unsupported:
if {[namespace which -command timerate] eq {}} {
namespace inscope ::tcl::unsupported {namespace export timerate}
namespace import ::tcl::unsupported::timerate
}
|
| ︙ | ︙ |
Changes to tests/apply.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
if {[info commands ::apply] eq {}} {
return
}
testConstraint memory [llength [info commands memory]]
# Tests for wrong number of arguments
test apply-1.1 {not enough arguments} -returnCodes error -body {
apply
} -result {wrong # args: should be "apply lambdaExpr ?arg ...?"}
| > > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
if {[info commands ::apply] eq {}} {
return
}
testConstraint memory [llength [info commands memory]]
testConstraint applylambda [llength [info commands testapplylambda]]
# Tests for wrong number of arguments
test apply-1.1 {not enough arguments} -returnCodes error -body {
apply
} -result {wrong # args: should be "apply lambdaExpr ?arg ...?"}
|
| ︙ | ︙ | |||
301 302 303 304 305 306 307 308 309 310 311 312 313 314 |
set end [getbytes]
}
set leakedBytes [expr {$end - $tmp}]
} -cleanup {
rename getbytes {}
unset -nocomplain end i x tmp leakedBytes
} -result 0
# Tests for the avoidance of recompilation
# cleanup
namespace delete testApply
| > > > > > > > | 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 |
set end [getbytes]
}
set leakedBytes [expr {$end - $tmp}]
} -cleanup {
rename getbytes {}
unset -nocomplain end i x tmp leakedBytes
} -result 0
# Tests for specific bugs
test apply-10.1 {Test for precompiled bytecode body} -constraints {
applylambda
} -body {
testapplylambda
} -result 42
# Tests for the avoidance of recompilation
# cleanup
namespace delete testApply
|
| ︙ | ︙ |
Changes to tests/chan.test.
| ︙ | ︙ | |||
51 52 53 54 55 56 57 |
chan configure stdout -eofchar Ā
} -returnCodes error -match glob -result {bad value*}
test chan-4.3 {chan command: [Bug 800753]} -body {
chan configure stdout -eofchar \x00
} -returnCodes error -match glob -result {bad value*}
test chan-4.4 {chan command: check valid inValue, no outValue} -body {
chan configure stdout -eofchar [list \x27 {}]
| | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
chan configure stdout -eofchar Ā
} -returnCodes error -match glob -result {bad value*}
test chan-4.3 {chan command: [Bug 800753]} -body {
chan configure stdout -eofchar \x00
} -returnCodes error -match glob -result {bad value*}
test chan-4.4 {chan command: check valid inValue, no outValue} -body {
chan configure stdout -eofchar [list \x27 {}]
} -result {}
test chan-4.5 {chan command: check valid inValue, invalid outValue} -body {
chan configure stdout -eofchar [list \x27 \x80]
} -returnCodes error -match glob -result {bad value for -eofchar:*}
test chan-4.6 {chan command: check no inValue, valid outValue} -body {
chan configure stdout -eofchar [list {} \x27]
} -result {} -cleanup {chan configure stdout -eofchar [list {} {}]}
test chan-5.1 {chan command: copy subcommand} -body {
chan copy foo
} -returnCodes error -result "wrong # args: should be \"chan copy input output ?-size size? ?-command callback?\""
test chan-6.1 {chan command: eof subcommand} -body {
chan eof foo bar
|
| ︙ | ︙ |
Changes to tests/chanio.test.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]
# some tests can only be run is umask is 2 if "umask" cannot be run, the
# tests will be skipped.
set umaskValue 0
testConstraint umask [expr {![catch {set umaskValue [scan [exec /bin/sh -c umask] %o]}]}]
| | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]
# some tests can only be run is umask is 2 if "umask" cannot be run, the
# tests will be skipped.
set umaskValue 0
testConstraint umask [expr {![catch {set umaskValue [scan [exec /bin/sh -c umask] %o]}]}]
testConstraint makeFileInHome [expr {![file exists $::env(HOME)/_test_] && [file writable $::env(HOME)]}]
# set up a long data file for some of the following tests
set path(longfile) [makeFile {} longfile]
set f [open $path(longfile) w]
chan configure $f -eofchar {} -translation lf
for { set i 0 } { $i < 100 } { incr i} {
|
| ︙ | ︙ | |||
5484 5485 5486 5487 5488 5489 5490 |
set f [open $path(test3) RDWR]
chan puts -nonewline $f "ab"
chan seek $f 0 current
set x [chan gets $f]
chan close $f
lappend x [viewFile test3]
} {zzy abzzy}
| | | > > | < > > < < < < < < < < | 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 |
set f [open $path(test3) RDWR]
chan puts -nonewline $f "ab"
chan seek $f 0 current
set x [chan gets $f]
chan close $f
lappend x [viewFile test3]
} {zzy abzzy}
test chan-io-40.16 {verify no tilde substitution in open} -setup {
set curdir [pwd]
cd [temporaryDirectory]
} -body {
close [open ~ w]
list [file isfile ~]
} -cleanup {
file delete ./~ ;# ./ because don't want to delete home in case of bugs!
cd $curdir
} -result 1
test chan-io-41.1 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
chan event foo
} -returnCodes error -result {wrong # args: should be "chan event channelId event ?script?"}
test chan-io-41.2 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
chan event foo bar baz q
} -returnCodes error -result {wrong # args: should be "chan event channelId event ?script?"}
|
| ︙ | ︙ |
Changes to tests/cmdAH.test.
| ︙ | ︙ | |||
96 97 98 99 100 101 102 |
set oldpwd [pwd]
set temp $env(HOME)
file delete -force $foodir
} -body {
set env(HOME) $oldpwd
file mkdir $foodir
cd $foodir
| | | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 |
set oldpwd [pwd]
set temp $env(HOME)
file delete -force $foodir
} -body {
set env(HOME) $oldpwd
file mkdir $foodir
cd $foodir
cd [file home]
string equal [pwd] $oldpwd
} -cleanup {
cd $oldpwd
file delete $foodir
set env(HOME) $temp
} -result 1
test cmdAH-2.4 {Tcl_CdObjCmd} -setup {
|
| ︙ | ︙ | |||
120 121 122 123 124 125 126 |
string equal [pwd] $oldpwd
} -cleanup {
cd $oldpwd
file delete $foodir
set env(HOME) $temp
} -result 1
test cmdAH-2.5 {Tcl_CdObjCmd} -returnCodes error -body {
| | > > > > > > > > > > > > > | | 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 |
string equal [pwd] $oldpwd
} -cleanup {
cd $oldpwd
file delete $foodir
set env(HOME) $temp
} -result 1
test cmdAH-2.5 {Tcl_CdObjCmd} -returnCodes error -body {
cd ~
} -result {couldn't change working directory to "~": no such file or directory}
test cmdAH-2.5.1 {Tcl_CdObjCmd} -setup {
set oldpwd [pwd]
cd [temporaryDirectory]
file delete ./~
file mkdir ~
} -body {
cd ~
pwd
} -cleanup {
cd [temporaryDirectory]
file delete ./~
cd $oldpwd
} -result [file join [temporaryDirectory] ~]
test cmdAH-2.6 {Tcl_CdObjCmd} -returnCodes error -body {
cd _foobar
} -result {couldn't change working directory to "_foobar": no such file or directory}
test cmdAH-2.6.1 {Tcl_CdObjCmd} -returnCodes error -body {
cd ""
} -result {couldn't change working directory to "": no such file or directory}
test cmdAH-2.6.2 {cd} -constraints {unix nonPortable} -setup {
|
| ︙ | ︙ | |||
168 169 170 171 172 173 174 |
encoding
} -result {wrong # args: should be "encoding subcommand ?arg ...?"}
test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body {
encoding foo
} -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system}
test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body {
encoding convertto
| | | 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 |
encoding
} -result {wrong # args: should be "encoding subcommand ?arg ...?"}
test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body {
encoding foo
} -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system}
test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body {
encoding convertto
} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"}
test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body {
encoding convertto foo bar
} -result {unknown encoding "foo"}
test cmdAH-4.5 {Tcl_EncodingObjCmd} -setup {
set system [encoding system]
} -body {
encoding system jis0208
|
| ︙ | ︙ | |||
190 191 192 193 194 195 196 |
encoding system iso8859-1
encoding convertto jis0208 乎
} -cleanup {
encoding system $system
} -result 8C
test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body {
encoding convertfrom
| | | 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 |
encoding system iso8859-1
encoding convertto jis0208 乎
} -cleanup {
encoding system $system
} -result 8C
test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body {
encoding convertfrom
} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"}
test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body {
encoding convertfrom foo bar
} -result {unknown encoding "foo"}
test cmdAH-4.9 {Tcl_EncodingObjCmd} -setup {
set system [encoding system]
} -body {
encoding system jis0208
|
| ︙ | ︙ | |||
224 225 226 227 228 229 230 231 232 233 234 235 236 |
set system [encoding system]
} -body {
encoding system iso8859-1
encoding system
} -cleanup {
encoding system $system
} -result iso8859-1
test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body {
file
} -result {wrong # args: should be "file subcommand ?arg ...?"}
test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body {
file x
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 364 365 366 367 368 369 370 371 372 |
set system [encoding system]
} -body {
encoding system iso8859-1
encoding system
} -cleanup {
encoding system $system
} -result iso8859-1
test cmdAH-4.14.1 {Syntax error, -nocomplain and -failindex, no encoding} -body {
encoding convertfrom -nocomplain -failindex 2 ABC
} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"}
test cmdAH-4.14.2 {Syntax error, -nocomplain and -failindex, no encoding} -body {
encoding convertto -nocomplain -failindex 2 ABC
} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"}
test cmdAH-4.15.1 {Syntax error, -failindex and -nocomplain, no encoding} -body {
encoding convertfrom -failindex 2 -nocomplain ABC
} -returnCodes 1 -result {unknown encoding "-nocomplain"}
test cmdAH-4.15.2 {Syntax error, -failindex and -nocomplain, no encoding} -body {
encoding convertto -failindex 2 -nocomplain ABC
} -returnCodes 1 -result {unknown encoding "-nocomplain"}
test cmdAH-4.16.1 {Syntax error, -nocomplain and -failindex, encoding} -body {
encoding convertfrom -nocomplain -failindex 2 utf-8 ABC
} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"}
test cmdAH-4.16.2 {Syntax error, -nocomplain and -failindex, encoding} -body {
encoding convertto -nocomplain -failindex 2 utf-8 ABC
} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"}
test cmdAH-4.17.1 {Syntax error, -failindex and -nocomplain, encoding} -body {
encoding convertfrom -failindex 2 -nocomplain utf-8 ABC
} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"}
test cmdAH-4.17.2 {Syntax error, -failindex and -nocomplain, encoding} -body {
encoding convertto -failindex 2 -nocomplain utf-8 ABC
} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"}
test cmdAH-4.18.1 {Syntax error, -failindex with no var, no encoding} -body {
encoding convertfrom -failindex ABC
} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"}
test cmdAH-4.18.2 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup {
proc encoding_test {} {
encoding convertfrom -failindex ABC
}
} -body {
# Compile and execute
encoding_test
} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} -cleanup {
rename encoding_test ""
}
test cmdAH-4.18.3 {Syntax error, -failindex with no var, no encoding} -body {
encoding convertto -failindex ABC
} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-failindex var? ?encoding? data"}
test cmdAH-4.18.4 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup {
proc encoding_test {} {
encoding convertto -failindex ABC
}
} -body {
# Compile and execute
encoding_test
} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-failindex var? ?encoding? data"} -cleanup {
rename encoding_test ""
}
test cmdAH-4.19.1 {convertrom -failindex with correct data} -body {
encoding convertfrom -failindex test ABC
set test
} -returnCodes 0 -result -1
test cmdAH-4.19.2 {convertrom -failindex with correct data (byt compiled)} -setup {
proc encoding_test {} {
encoding convertfrom -failindex test ABC
set test
}
} -body {
# Compile and execute
encoding_test
} -returnCodes 0 -result -1 -cleanup {
rename encoding_test ""
}
test cmdAH-4.19.3 {convertrom -failindex with correct data} -body {
encoding convertto -failindex test ABC
set test
} -returnCodes 0 -result -1
test cmdAH-4.19.4 {convertrom -failindex with correct data (byt compiled)} -setup {
proc encoding_test {} {
encoding convertto -failindex test ABC
set test
}
} -body {
# Compile and execute
encoding_test
} -returnCodes 0 -result -1 -cleanup {
rename encoding_test ""
}
test cmdAH-4.20.1 {convertrom -failindex with incomplete utf8} -body {
set x [encoding convertfrom -failindex i utf-8 A\xc3]
binary scan $x H* y
list $y $i
} -returnCodes 0 -result {41c3 -1}
test cmdAH-4.20.2 {convertrom -failindex with incomplete utf8 (byte compiled)} -setup {
proc encoding_test {} {
set x [encoding convertfrom -failindex i utf-8 A\xc3]
binary scan $x H* y
list $y $i
}
} -body {
# Compile and execute
encoding_test
} -returnCodes 0 -result {41c3 -1} -cleanup {
rename encoding_test ""
}
test cmdAH-4.21.1 {convertto -failindex with wrong character} -body {
set x [encoding convertto -failindex i iso8859-1 A\u0141]
binary scan $x H* y
list $y $i
} -returnCodes 0 -result {41 1}
test cmdAH-4.21.2 {convertto -failindex with wrong character (byte compiled)} -setup {
proc encoding_test {} {
set x [encoding convertto -failindex i iso8859-1 A\u0141]
binary scan $x H* y
list $y $i
}
} -body {
# Compile and execute
encoding_test
} -returnCodes 0 -result {41 1} -cleanup {
rename encoding_test ""
}
test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body {
file
} -result {wrong # args: should be "file subcommand ?arg ...?"}
test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body {
file x
} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, home, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, tildeexpand, type, volumes, or writable}
test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body {
file exists
} -result {wrong # args: should be "file exists name"}
test cmdAH-5.4 {Tcl_FileObjCmd} {
file exists ""
} 0
|
| ︙ | ︙ | |||
377 378 379 380 381 382 383 |
} ~bar
test cmdAH-8.43 {Tcl_FileObjCmd: dirname} -setup {
global env
set temp $env(HOME)
} -constraints testsetplatform -body {
set env(HOME) "/homewontexist/test"
testsetplatform unix
| | | | | < < < < < < | | 505 506 507 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 |
} ~bar
test cmdAH-8.43 {Tcl_FileObjCmd: dirname} -setup {
global env
set temp $env(HOME)
} -constraints testsetplatform -body {
set env(HOME) "/homewontexist/test"
testsetplatform unix
file dirname [file home]
} -cleanup {
set env(HOME) $temp
} -result /homewontexist
test cmdAH-8.44 {Tcl_FileObjCmd: dirname} -setup {
global env
set temp $env(HOME)
} -constraints testsetplatform -body {
set env(HOME) "~"
testsetplatform unix
file dirname [file home]
} -cleanup {
set env(HOME) $temp
} -result .
test cmdAH-8.45 {Tcl_FileObjCmd: dirname ~} -body {
file dirname ~
} -result .
test cmdAH-8.46 {Tcl_FileObjCmd: dirname} {
set f [file normalize [info nameof]]
file exists $f
set res1 [file dirname [file join $f foo/bar]]
set res2 [file dirname "${f}/foo/bar"]
if {$res1 eq $res2} {
return "ok"
|
| ︙ | ︙ | |||
507 508 509 510 511 512 513 |
testsetplatform windows
file tail {//foo/bar/baz}
} baz
test cmdAH-9.26 {Tcl_FileObjCmd: tail} testsetplatform {
testsetplatform windows
file tail {//foo/bar}
} {}
| | < < < < < < < | | | < < < < < < < < < < | 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 |
testsetplatform windows
file tail {//foo/bar/baz}
} baz
test cmdAH-9.26 {Tcl_FileObjCmd: tail} testsetplatform {
testsetplatform windows
file tail {//foo/bar}
} {}
test cmdAH-9.42 {Tcl_FileObjCmd: tail ~} -body {
file tail ~
} -result ~
test cmdAH-9.43 {Tcl_FileObjCmd: tail} -constraints testsetplatform -setup {
global env
set temp $env(HOME)
} -body {
set env(HOME) "~"
testsetplatform unix
file tail [file home]
} -cleanup {
set env(HOME) $temp
} -result ~
test cmdAH-9.46 {Tcl_FileObjCmd: tail} testsetplatform {
testsetplatform unix
file tail {f.oo\bar/baz.bat}
} baz.bat
test cmdAH-9.47 {Tcl_FileObjCmd: tail} testsetplatform {
testsetplatform windows
file tail c:foo
|
| ︙ | ︙ | |||
567 568 569 570 571 572 573 |
} bar
test cmdAH-9.52 {Tcl_FileObjCmd: tail / normalize, bug 7a9dc52b29} {
list \
[file tail {~/~foo}] \
[file tail {~/test/~foo}] \
[file tail [file normalize {~/~foo}]] \
[file tail [file normalize {~/test/~foo}]]
| | | 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 |
} bar
test cmdAH-9.52 {Tcl_FileObjCmd: tail / normalize, bug 7a9dc52b29} {
list \
[file tail {~/~foo}] \
[file tail {~/test/~foo}] \
[file tail [file normalize {~/~foo}]] \
[file tail [file normalize {~/test/~foo}]]
} [lrepeat 4 ~foo]
# rootname
test cmdAH-10.1 {Tcl_FileObjCmd: rootname} -returnCodes error -body {
file rootname a b
} -result {wrong # args: should be "file rootname name"}
test cmdAH-10.2 {Tcl_FileObjCmd: rootname} testsetplatform {
testsetplatform unix
|
| ︙ | ︙ | |||
821 822 823 824 825 826 827 |
file join a b c d
} a/b/c/d
# error handling of Tcl_TranslateFileName
test cmdAH-15.1 {Tcl_FileObjCmd} -constraints testsetplatform -body {
testsetplatform unix
file atime ~_bad_user
| | | 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 |
file join a b c d
} a/b/c/d
# error handling of Tcl_TranslateFileName
test cmdAH-15.1 {Tcl_FileObjCmd} -constraints testsetplatform -body {
testsetplatform unix
file atime ~_bad_user
} -returnCodes error -result {could not read "~_bad_user": no such file or directory}
catch {testsetplatform $platform}
# readable
set gorpfile [makeFile abcde gorp.file]
set dirfile [makeDirectory dir.file]
test cmdAH-16.1 {Tcl_FileObjCmd: readable} {
|
| ︙ | ︙ | |||
944 945 946 947 948 949 950 |
} -constraints testsetplatform -cleanup {
testsetplatform $platform
} -result {a\b}
test cmdAH-19.9 {Tcl_FileObjCmd: ~ : exists} {
file exists ~nOsUcHuSeR
} 0
test cmdAH-19.10 {Tcl_FileObjCmd: ~ : nativename} -body {
| < | | 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 |
} -constraints testsetplatform -cleanup {
testsetplatform $platform
} -result {a\b}
test cmdAH-19.9 {Tcl_FileObjCmd: ~ : exists} {
file exists ~nOsUcHuSeR
} 0
test cmdAH-19.10 {Tcl_FileObjCmd: ~ : nativename} -body {
file nativename ~nOsUcHuSeR
} -result ~nOsUcHuSeR
# The test below has to be done in /tmp rather than the current directory in
# order to guarantee (?) a local file system: some NFS file systems won't do
# the stuff below correctly.
test cmdAH-19.11 {Tcl_FileObjCmd: exists} -constraints {unix notRoot} -setup {
file delete -force /tmp/tcl.foo.dir/file
file delete -force /tmp/tcl.foo.dir
} -body {
|
| ︙ | ︙ | |||
1561 1562 1563 1564 1565 1566 1567 |
}
set res
} -result "characterSpecial"
# Error conditions
test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
file gorp x
| | < < < | 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 |
}
set res
} -result "characterSpecial"
# Error conditions
test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
file gorp x
} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, home, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, tildeexpand, type, volumes, or writable}
test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
file ex x
} -match glob -result {unknown or ambiguous subcommand "ex": must be *}
test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
file is x
} -match glob -result {unknown or ambiguous subcommand "is": must be *}
test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
file z x
} -match glob -result {unknown or ambiguous subcommand "z": must be *}
test cmdAH-30.5 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
file read x
} -match glob -result {unknown or ambiguous subcommand "read": must be *}
test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
file s x
} -match glob -result {unknown or ambiguous subcommand "s": must be *}
test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
file t x
} -match glob -result {unknown or ambiguous subcommand "t": must be *}
# channels
# In testing 'file channels', we need to make sure that a channel created in
# one interp isn't visible in another.
interp create simpleInterp
interp create -safe safeInterp
|
| ︙ | ︙ |
Changes to tests/cmdMZ.test.
| ︙ | ︙ | |||
154 155 156 157 158 159 160 |
while executing
"return -level 0 -code error"} -errorline 1 -errorstack * -level 0}}
test cmdMZ-return-2.11 {return option handling} {
list [catch {return -level 0 -code break} -> foo] [dictSort $foo]
} {3 {-code 3 -level 0}}
test cmdMZ-return-2.12 {return option handling} -body {
return -level 0 -code error -options {-code ok}
| | | 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 |
while executing
"return -level 0 -code error"} -errorline 1 -errorstack * -level 0}}
test cmdMZ-return-2.11 {return option handling} {
list [catch {return -level 0 -code break} -> foo] [dictSort $foo]
} {3 {-code 3 -level 0}}
test cmdMZ-return-2.12 {return option handling} -body {
return -level 0 -code error -options {-code ok}
} -result {}
test cmdMZ-return-2.13 {return option handling} -body {
return -level 0 -code error -options {-code err}
} -returnCodes error -match glob -result {bad completion code "err": must be ok, error, return, break, continue*, or an integer}
test cmdMZ-return-2.14 {return option handling} -body {
return -level 0 -code error -options {-code foo -options {-code break}}
} -returnCodes break -result {}
test cmdMZ-return-2.15 {return opton handling} {
|
| ︙ | ︙ |
Changes to tests/compile.test.
| ︙ | ︙ | |||
648 649 650 651 652 653 654 |
# suite.
#
test compile-16.18.$noComp {TclCompileScript: word expansion} -body {
proc LongList {} {return [lrepeat [expr {1<<10}] x]}
llength [run "list [string repeat {{*}[LongList] } [expr {1<<10}]]"]
} -constraints [linsert $constraints 0 knownBug] -cleanup {
rename LongList {}
| | | | | | | | 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 |
# suite.
#
test compile-16.18.$noComp {TclCompileScript: word expansion} -body {
proc LongList {} {return [lrepeat [expr {1<<10}] x]}
llength [run "list [string repeat {{*}[LongList] } [expr {1<<10}]]"]
} -constraints [linsert $constraints 0 knownBug] -cleanup {
rename LongList {}
} -result [expr {1<<20}]
test compile-16.19.$noComp {TclCompileScript: word expansion} -body {
proc LongList {} {return [lrepeat [expr {1<<11}] x]}
llength [run "list [string repeat {{*}[LongList] } [expr {1<<11}]]"]
} -constraints [linsert $constraints 0 knownBug] -cleanup {
rename LongList {}
} -result [expr {1<<22}]
test compile-16.20.$noComp {TclCompileScript: word expansion} -body {
proc LongList {} {return [lrepeat [expr {1<<12}] x]}
llength [run "list [string repeat {{*}[LongList] } [expr {1<<12}]]"]
} -constraints [linsert $constraints 0 knownBug] -cleanup {
rename LongList {}
} -result [expr {1<<24}]
# This is the one that should cause overflow
test compile-16.21.$noComp {TclCompileScript: word expansion} -body {
proc LongList {} {return [lrepeat [expr {1<<16}] x]}
llength [run "list [string repeat {{*}[LongList] } [expr {1<<16}]]"]
} -constraints [linsert $constraints 0 knownBug] -cleanup {
rename LongList {}
} -result [expr {wide(1)<<32}]
test compile-16.22.$noComp {
Bug 845412: TclCompileScript: word expansion not mandatory
} -body {
# This test may crash and will fail unless Bug 845412 is fixed.
proc ReturnResults args {return $args}
run "ReturnResults [string repeat {x } 260]"
} -constraints $constraints -cleanup {
rename ReturnResults {}
} -result [string trim [string repeat {x } 260]]
test compile-16.23.$noComp {
Bug 1032805: defer parse error until run time
} -constraints $constraints -body {
namespace eval x {
run {
proc if {a b} {uplevel 1 [list set $a $b]}
if 1 {syntax {}{}}
}
}
} -cleanup {
namespace delete x
} -result {syntax {}{}}
test compile-16.24.$noComp {
Bug 1638414: bad list constant as first expanded term
} -constraints $constraints -body {
run "{*}\"\{foo bar\""
} -returnCodes error -result {unmatched open brace in list}
test compile-16.25.$noComp {TclCompileScript: word expansion, naked backslashes} $constraints {
run {list {*}{a \n b}}
|
| ︙ | ︙ |
Changes to tests/encoding.test.
| ︙ | ︙ | |||
36 37 38 39 40 41 42 | # Some tests require the testencoding command testConstraint testencoding [llength [info commands testencoding]] testConstraint testbytestring [llength [info commands testbytestring]] testConstraint teststringbytes [llength [info commands teststringbytes]] testConstraint exec [llength [info commands exec]] testConstraint testgetencpath [llength [info commands testgetencpath]] | > > > | | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
# Some tests require the testencoding command
testConstraint testencoding [llength [info commands testencoding]]
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint teststringbytes [llength [info commands teststringbytes]]
testConstraint exec [llength [info commands exec]]
testConstraint testgetencpath [llength [info commands testgetencpath]]
testConstraint fullutf [expr {[format %c 0x010000] ne "\uFFFD"}]
testConstraint utf32 [expr {[testConstraint fullutf]
&& [string length [format %c 0x10000]] == 1}]
# TclInitEncodingSubsystem is tested by the rest of this file
# TclFinalizeEncodingSubsystem is not currently tested
test encoding-1.1 {Tcl_GetEncoding: system encoding} -setup {
set old [encoding system]
} -constraints {testencoding} -body {
testencoding create foo [namespace origin toutf] [namespace origin fromutf]
|
| ︙ | ︙ | |||
332 333 334 335 336 337 338 |
test encoding-15.3 {UtfToUtfProc null character input} teststringbytes {
set y [encoding convertfrom utf-8 [encoding convertto utf-8 \x00]]
binary scan [teststringbytes $y] H* z
set z
} c080
test encoding-15.4 {UtfToUtfProc emoji character input} -body {
set x \xED\xA0\xBD\xED\xB8\x82
| | | | | | | | | | | | | | | | | | | | | | | | 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 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 |
test encoding-15.3 {UtfToUtfProc null character input} teststringbytes {
set y [encoding convertfrom utf-8 [encoding convertto utf-8 \x00]]
binary scan [teststringbytes $y] H* z
set z
} c080
test encoding-15.4 {UtfToUtfProc emoji character input} -body {
set x \xED\xA0\xBD\xED\xB8\x82
set y [encoding convertfrom -nocomplain utf-8 \xED\xA0\xBD\xED\xB8\x82]
list [string length $x] $y
} -result "6 \uD83D\uDE02"
test encoding-15.5 {UtfToUtfProc emoji character input} {
set x \xF0\x9F\x98\x82
set y [encoding convertfrom utf-8 \xF0\x9F\x98\x82]
list [string length $x] $y
} "4 😂"
test encoding-15.6 {UtfToUtfProc emoji character output} utf32 {
set x \uDE02\uD83D\uDE02\uD83D
set y [encoding convertto -nocomplain utf-8 \uDE02\uD83D\uDE02\uD83D]
binary scan $y H* z
list [string length $y] $z
} {12 efbfbdefbfbdefbfbdefbfbd}
test encoding-15.7 {UtfToUtfProc emoji character output} utf32 {
set x \uDE02\uD83D\uD83D
set y [encoding convertto -nocomplain utf-8 \uDE02\uD83D\uD83D]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {3 9 efbfbdefbfbdefbfbd}
test encoding-15.8 {UtfToUtfProc emoji character output} utf32 {
set x \uDE02\uD83Dé
set y [encoding convertto -nocomplain utf-8 \uDE02\uD83Dé]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {3 8 efbfbdefbfbdc3a9}
test encoding-15.9 {UtfToUtfProc emoji character output} utf32 {
set x \uDE02\uD83DX
set y [encoding convertto -nocomplain utf-8 \uDE02\uD83DX]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {3 7 efbfbdefbfbd58}
test encoding-15.10 {UtfToUtfProc high surrogate character output} utf32 {
set x \uDE02é
set y [encoding convertto -nocomplain utf-8 \uDE02é]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {2 5 efbfbdc3a9}
test encoding-15.11 {UtfToUtfProc low surrogate character output} utf32 {
set x \uDA02é
set y [encoding convertto -nocomplain utf-8 \uDA02é]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {2 5 efbfbdc3a9}
test encoding-15.12 {UtfToUtfProc high surrogate character output} utf32 {
set x \uDE02Y
set y [encoding convertto -nocomplain utf-8 \uDE02Y]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {2 4 efbfbd59}
test encoding-15.13 {UtfToUtfProc low surrogate character output} utf32 {
set x \uDA02Y
set y [encoding convertto -nocomplain utf-8 \uDA02Y]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {2 4 efbfbd59}
test encoding-15.14 {UtfToUtfProc high surrogate character output} utf32 {
set x \uDE02
set y [encoding convertto -nocomplain utf-8 \uDE02]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {1 3 efbfbd}
test encoding-15.15 {UtfToUtfProc low surrogate character output} utf32 {
set x \uDA02
set y [encoding convertto -nocomplain utf-8 \uDA02]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {1 3 efbfbd}
test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} {
set x \xF0\xA0\xA1\xC2
set y [encoding convertfrom -nocomplain utf-8 \xF0\xA0\xA1\xC2]
list [string length $x] $y
} "4 \xF0\xA0\xA1\xC2"
test encoding-15.17 {UtfToUtfProc emoji character output} {
set x 😂
|
| ︙ | ︙ | |||
663 664 665 666 667 668 669 |
string length [encoding convertfrom -nocomplain "\x20"]
} 1
test encoding-24.21 {Parse with -nocomplain but without providing encoding} {
string length [encoding convertto -nocomplain "\x20"]
} 1
test encoding-24.22 {Syntax error, two encodings} -body {
encoding convertfrom iso8859-1 utf-8 "ZX\uD800"
| | | | 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 |
string length [encoding convertfrom -nocomplain "\x20"]
} 1
test encoding-24.21 {Parse with -nocomplain but without providing encoding} {
string length [encoding convertto -nocomplain "\x20"]
} 1
test encoding-24.22 {Syntax error, two encodings} -body {
encoding convertfrom iso8859-1 utf-8 "ZX\uD800"
} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"}
test encoding-24.23 {Syntax error, two encodings} -body {
encoding convertto iso8859-1 utf-8 "ZX\uD800"
} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-failindex var? ?encoding? data"}
file delete [file join [temporaryDirectory] iso2022.txt]
#
# Begin jajp encoding round-trip conformity tests
#
proc foreach-jisx0208 {varName command} {
|
| ︙ | ︙ |
Changes to tests/env.test.
| ︙ | ︙ | |||
103 104 105 106 107 108 109 110 111 112 113 114 115 116 |
TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY
SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH
DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING MSYSTEM
__CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM
CommonProgramFiles CommonProgramFiles(x86) ProgramFiles
ProgramFiles(x86) CommonProgramW6432 ProgramW6432
WINECONFIGDIR WINEDATADIR WINEDLLDIR0 WINEHOMEDIR PROCESSOR_ARCHITECTURE
}
variable printenvScript [makeFile [string map [list @keep@ [list $keep]] {
encoding system iso8859-1
proc lrem {listname name} {
upvar $listname list
set i [lsearch -nocase $list $name]
| > | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 |
TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY
SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH
DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING MSYSTEM
__CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM
CommonProgramFiles CommonProgramFiles(x86) ProgramFiles
ProgramFiles(x86) CommonProgramW6432 ProgramW6432
WINECONFIGDIR WINEDATADIR WINEDLLDIR0 WINEHOMEDIR PROCESSOR_ARCHITECTURE
USERPROFILE
}
variable printenvScript [makeFile [string map [list @keep@ [list $keep]] {
encoding system iso8859-1
proc lrem {listname name} {
upvar $listname list
set i [lsearch -nocase $list $name]
|
| ︙ | ︙ | |||
407 408 409 410 411 412 413 |
}
trace add variable ::env(not_yet_existent) write foo
info exists ::env(not_yet_existent)
set ::env(not_yet_existent) "Now I'm here";
return [info exists ::env(test7_3)]
}}
} -cleanup cleanup1 -result 1
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 470 |
}
trace add variable ::env(not_yet_existent) write foo
info exists ::env(not_yet_existent)
set ::env(not_yet_existent) "Now I'm here";
return [info exists ::env(test7_3)]
}}
} -cleanup cleanup1 -result 1
test env-8.0 {
memory usage - valgrind does not report reachable memory
} -body {
set res [set env(__DUMMY__) {i'm with dummy}]
unset env(__DUMMY__)
return $res
} -result {i'm with dummy}
test env-9.0 {
Initialization of HOME from HOMEDRIVE and HOMEPATH
} -constraints win -setup {
setup1
unset -nocomplain ::env(HOME)
set ::env(HOMEDRIVE) X:
set ::env(HOMEPATH) \\home\\path
} -cleanup {
cleanup1
} -body {
set pipe [open |[list [interpreter]] r+]
puts $pipe {puts $::env(HOME); flush stdout; exit}
flush $pipe
set result [gets $pipe]
close $pipe
set result
} -result {X:\home\path}
test env-9.1 {
Initialization of HOME from USERPROFILE
} -constraints win -setup {
setup1
unset -nocomplain ::env(HOME)
unset -nocomplain ::env(HOMEDRIVE)
unset -nocomplain ::env(HOMEPATH)
} -cleanup {
cleanup1
} -body {
set pipe [open |[list [interpreter]] r+]
puts $pipe {puts $::env(HOME); flush stdout; exit}
flush $pipe
set result [gets $pipe]
close $pipe
if {$result ne $::env(USERPROFILE)} {
list ERROR $result ne $::env(USERPROFILE)
}
} -result {}
# cleanup
rename getenv {}
rename envrestore {}
rename envprep {}
rename encodingrestore {}
rename encodingswitch {}
|
| ︙ | ︙ |
Changes to tests/exec.test.
| ︙ | ︙ | |||
436 437 438 439 440 441 442 |
} -returnCodes error -result "channel \"$f\" wasn't opened for reading"
close $f
set f [open $path(gorp.file) r]
test exec-10.19 {errors in exec invocation} -constraints {exec} -body {
exec cat >@ $f
} -returnCodes error -result "channel \"$f\" wasn't opened for writing"
close $f
| | > > > > > > | | | | | 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 |
} -returnCodes error -result "channel \"$f\" wasn't opened for reading"
close $f
set f [open $path(gorp.file) r]
test exec-10.19 {errors in exec invocation} -constraints {exec} -body {
exec cat >@ $f
} -returnCodes error -result "channel \"$f\" wasn't opened for writing"
close $f
test exec-10.20.1 {errors in exec invocation} -constraints {unix exec notValgrind} -body {
exec ~non_existent_user/foo/bar
} -returnCodes error -result {couldn't execute "~non_existent_user/foo/bar": no such file or directory}
test exec-10.20.1 {errors in exec invocation} -constraints {win exec notValgrind} -body {
exec ~non_existent_user/foo/bar
} -returnCodes error -result {couldn't execute "~non_existent_user\foo\bar": no such file or directory}
test exec-10.21.1 {errors in exec invocation} -constraints {unix exec notValgrind} -body {
exec [interpreter] true | ~xyzzy_bad_user/x | false
} -returnCodes error -result {couldn't execute "~xyzzy_bad_user/x": no such file or directory}
test exec-10.21.2 {errors in exec invocation} -constraints {win exec notValgrind} -body {
exec [interpreter] true | ~xyzzy_bad_user/x | false
} -returnCodes error -result {couldn't execute "~xyzzy_bad_user\x": no such file or directory}
test exec-10.22 {errors in exec invocation} -constraints {exec notValgrind} -body {
exec echo test > ~non_existent_user/foo/bar
} -returnCodes error -result {couldn't write file "~non_existent_user/foo/bar": no such file or directory}
# Commands in background.
test exec-11.1 {commands in background} {exec} {
set time [time {exec [interpreter] $path(sleep) 2 &}]
expr {[lindex $time 0] < 1000000}
} 1
test exec-11.2 {commands in background} -constraints {exec} -body {
|
| ︙ | ︙ |
Changes to tests/fCmd.test.
| ︙ | ︙ | |||
92 93 94 95 96 97 98 99 100 101 102 103 104 105 |
regexp {^[^(]*\(([^)]*)\)} [exec id] -> user
}
}
if {$user eq ""} {
set user "root"
}
}
proc createfile {file {string a}} {
set f [open $file w]
puts -nonewline $f $string
close $f
return $string
}
| > > > > > > > > | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 |
regexp {^[^(]*\(([^)]*)\)} [exec id] -> user
}
}
if {$user eq ""} {
set user "root"
}
}
if {[testConstraint win]} {
catch {
set user $::env(USERNAME)
}
if {$user eq ""} {
set user Administrator
}
}
proc createfile {file {string a}} {
set f [open $file w]
puts -nonewline $f $string
close $f
return $string
}
|
| ︙ | ︙ | |||
118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 |
} on error {} {
return 0
}
return [string match $matchString $fileString]
}
proc openup {path} {
testchmod 0o777 $path
if {[file isdirectory $path]} {
catch {
foreach p [glob -directory $path *] {
openup $p
}
}
}
}
proc cleanup {args} {
set wd [list .]
foreach p [concat $wd $args] {
set x ""
catch {
| > > > > | > > > > | 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 158 159 160 161 162 163 164 165 |
} on error {} {
return 0
}
return [string match $matchString $fileString]
}
proc openup {path} {
# Double check for inadvertent ~ -> home directory mapping
if {[string match ~* $path]} {
set file ./$path
}
testchmod 0o777 $path
if {[file isdirectory $path]} {
catch {
foreach p [glob -directory $path *] {
openup $p
}
}
}
}
proc cleanup {args} {
set wd [list .]
foreach p [concat $wd $args] {
set x ""
catch {
set x [glob -directory $p tf* td* ~*]
}
foreach file $x {
# Double check for inadvertent ~ -> home directory mapping
if {[string match ~* $file]} {
set file ./$file
}
if {
[catch {file delete -force -- $file}]
&& [testConstraint testchmod]
} then {
catch {openup $file}
catch {file delete -force -- $file}
}
|
| ︙ | ︙ | |||
175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 |
test fCmd-1.1 {TclFileRenameCmd} -constraints {notRoot} -setup {
cleanup
} -body {
createfile tf1
file rename tf1 tf2
glob tf*
} -result {tf2}
test fCmd-2.1 {TclFileCopyCmd} -constraints {notRoot} -setup {
cleanup
} -body {
createfile tf1
file copy tf1 tf2
lsort [glob tf*]
} -result {tf1 tf2}
test fCmd-3.1 {FileCopyRename: FileForceOption fails} -constraints {notRoot} -body {
file rename -xyz
} -returnCodes error -result {bad option "-xyz": must be -force or --}
test fCmd-3.2 {FileCopyRename: not enough args} -constraints {notRoot} -body {
file rename xyz
} -returnCodes error -result {wrong # args: should be "file rename ?-option value ...? source ?source ...? target"}
test fCmd-3.3 {FileCopyRename: Tcl_TranslateFileName fails} -constraints {notRoot} -body {
file rename xyz ~_totally_bogus_user
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 219 220 221 222 223 224 225 226 227 228 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 |
test fCmd-1.1 {TclFileRenameCmd} -constraints {notRoot} -setup {
cleanup
} -body {
createfile tf1
file rename tf1 tf2
glob tf*
} -result {tf2}
test fCmd-1.2 {TclFileRenameCmd when target is ~} -setup {
cleanup
createfile tf1
} -cleanup {
file delete ./~
} -body {
file rename tf1 ~
file isfile ~
} -result 1
test fCmd-1.3 {TclFileRenameCmd when target is ~user} -setup {
cleanup
createfile tf1
} -cleanup {
file delete ./~$user
} -body {
file rename tf1 ~$user
file isfile ~$user
} -result 1
test fCmd-1.4 {TclFileRenameCmd when source is ~} -setup {
cleanup
createfile ./~
} -cleanup {
file delete ./~
} -body {
file rename ~ tf1
list [file exists ~] [file exists tf1]
} -result {0 1}
test fCmd-1.5 {TclFileRenameCmd when source is ~user} -setup {
cleanup
createfile ./~$user
} -cleanup {
file delete ./~$user
} -body {
file rename ~$user tf1
list [file exists ~$user] [file exists tf1]
} -result {0 1}
test fCmd-2.1 {TclFileCopyCmd} -constraints {notRoot} -setup {
cleanup
} -body {
createfile tf1
file copy tf1 tf2
lsort [glob tf*]
} -result {tf1 tf2}
test fCmd-2.2 {TclFileCopyCmd when target is ~} -setup {
cleanup
createfile tf1
} -cleanup {
file delete ./~
} -body {
file copy tf1 ~
list [file exists tf1] [file exists ~]
} -result {1 1}
test fCmd-2.3 {TclFileCopyCmd when target is ~user} -setup {
cleanup
createfile tf1
} -cleanup {
file delete ./~$user
} -body {
file copy tf1 ~$user
list [file exists tf1] [file exists ~$user]
} -result {1 1}
test fCmd-2.4 {TclFileCopyCmd when source is ~} -setup {
cleanup
createfile ./~
} -cleanup {
file delete ./~
} -body {
file copy ~ tf1
list [file exists ~] [file exists tf1]
} -result {1 1}
test fCmd-2.5 {TclFileCopyCmd when source is ~user} -setup {
cleanup
createfile ./~$user
} -cleanup {
file delete ./~$user
} -body {
file copy ~$user tf1
list [file exists ~$user] [file exists tf1]
} -result {1 1}
test fCmd-3.1 {FileCopyRename: FileForceOption fails} -constraints {notRoot} -body {
file rename -xyz
} -returnCodes error -result {bad option "-xyz": must be -force or --}
test fCmd-3.2 {FileCopyRename: not enough args} -constraints {notRoot} -body {
file rename xyz
} -returnCodes error -result {wrong # args: should be "file rename ?-option value ...? source ?source ...? target"}
test fCmd-3.3 {FileCopyRename: Tcl_TranslateFileName fails} -constraints {notRoot} -body {
file rename xyz ~_totally_bogus_user
} -returnCodes error -result {error renaming "xyz": no such file or directory}
test fCmd-3.4 {FileCopyRename: Tcl_TranslateFileName passes} -setup {
cleanup
} -constraints {notRoot} -returnCodes error -body {
file copy tf1 ~
} -result {error copying "tf1": no such file or directory}
test fCmd-3.5 {FileCopyRename: target doesn't exist: stat(target) != 0} -setup {
cleanup
|
| ︙ | ︙ | |||
266 267 268 269 270 271 272 |
[contents [file join td1 tf3]] [contents [file join td1 tf4]]
} -result {tf1 tf2 tf3 tf4}
test fCmd-3.14 {FileCopyRename: FileBasename fails} -setup {
cleanup
} -constraints {notRoot} -returnCodes error -body {
file mkdir td1
file rename ~_totally_bogus_user td1
| | | 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 |
[contents [file join td1 tf3]] [contents [file join td1 tf4]]
} -result {tf1 tf2 tf3 tf4}
test fCmd-3.14 {FileCopyRename: FileBasename fails} -setup {
cleanup
} -constraints {notRoot} -returnCodes error -body {
file mkdir td1
file rename ~_totally_bogus_user td1
} -result {error renaming "~_totally_bogus_user": no such file or directory}
test fCmd-3.15 {FileCopyRename: source[0] == '\x00'} -setup {
cleanup
} -constraints {notRoot unixOrWin} -returnCodes error -body {
file mkdir td1
file rename / td1
} -result {error renaming "/" to "td1": file already exists}
test fCmd-3.16 {FileCopyRename: break on first error} -setup {
|
| ︙ | ︙ | |||
304 305 306 307 308 309 310 |
test fCmd-4.3 {TclFileMakeDirsCmd: stops on first error} -setup {
cleanup
} -constraints {notRoot} -body {
createfile tf1
catch {file mkdir td1 td2 tf1 td3 td4}
glob td1 td2 tf1 td3 td4
} -result {td1 td2 tf1}
| | | > > > > > > | | 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 |
test fCmd-4.3 {TclFileMakeDirsCmd: stops on first error} -setup {
cleanup
} -constraints {notRoot} -body {
createfile tf1
catch {file mkdir td1 td2 tf1 td3 td4}
glob td1 td2 tf1 td3 td4
} -result {td1 td2 tf1}
test fCmd-4.4 {TclFileMakeDirsCmd: Tcl_TranslateFileName treats ~ as normal char} -setup {
cleanup
} -constraints {notRoot} -body {
list [file isdir ~] [file mkdir ~] [file isdir ~]
} -result {0 {} 1}
test fCmd-4.4.1 {TclFileMakeDirsCmd: Tcl_TranslateFileName treats ~ as normal char} -setup {
cleanup
} -constraints {notRoot} -body {
file mkdir ~_totally_bogus_user
file isdir ~_totally_bogus_user
} -result 1
test fCmd-4.5 {TclFileMakeDirsCmd: Tcl_SplitPath returns 0: *name == '\x00'} -setup {
cleanup
} -constraints {notRoot} -returnCodes error -body {
file mkdir ""
} -result {can't create directory "": no such file or directory}
test fCmd-4.6 {TclFileMakeDirsCmd: one level deep} -setup {
cleanup
|
| ︙ | ︙ | |||
416 417 418 419 420 421 422 |
} -constraints {notRoot unixOrWin notWine} -body {
createfile tf1
createfile tf2
file mkdir td1
catch {file delete tf1 td1 $root tf2}
list [file exists tf1] [file exists tf2] [file exists td1]
} -cleanup {cleanup} -result {0 1 0}
| > > | | > | < < | | 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 |
} -constraints {notRoot unixOrWin notWine} -body {
createfile tf1
createfile tf2
file mkdir td1
catch {file delete tf1 td1 $root tf2}
list [file exists tf1] [file exists tf2] [file exists td1]
} -cleanup {cleanup} -result {0 1 0}
test fCmd-5.6 {
TclFileDeleteCmd: Tcl_TranslateFileName treats ~user as normal char
} -constraints {notRoot} -body {
file delete ~_totally_bogus_user
} -result {}
test fCmd-5.7 {
TclFileDeleteCmd: Tcl_TranslateFileName treats ~ as normal char
} -constraints {notRoot} -body {
createfile ~/tf1
} -returnCodes error -result {couldn't open "~/tf1": no such file or directory}
test fCmd-5.8 {TclFileDeleteCmd: file doesn't exist: lstat(name) != 0} -setup {
cleanup
} -constraints {notRoot} -body {
set x [file exists tf1]
file delete tf1
list $x [file exists tf1]
} -result {0 0}
|
| ︙ | ︙ | |||
623 624 625 626 627 628 629 |
} -returnCodes error -cleanup {
file attributes td1 -permissions 0o755
cleanup
} -match regexp -result {^error renaming "td1"( to "/tmp/tcl\d+/td1")?: permission denied$}
test fCmd-6.24 {CopyRenameOneFile: error uses original name} -setup {
cleanup
} -constraints {unix notRoot} -body {
| | | | | | | | | | | | | | | | | 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 |
} -returnCodes error -cleanup {
file attributes td1 -permissions 0o755
cleanup
} -match regexp -result {^error renaming "td1"( to "/tmp/tcl\d+/td1")?: permission denied$}
test fCmd-6.24 {CopyRenameOneFile: error uses original name} -setup {
cleanup
} -constraints {unix notRoot} -body {
file mkdir [file home]/td1/td2
set td1name [file join [file dirname [file home]] [file tail [file home]] td1]
file attributes $td1name -permissions 0
file copy [file home]/td1 td1
} -returnCodes error -cleanup {
file attributes $td1name -permissions 0o755
file delete -force [file home]/td1
} -result "error copying \"[file home]/td1\": permission denied"
test fCmd-6.25 {CopyRenameOneFile: error uses original name} -setup {
cleanup
} -constraints {unix notRoot} -body {
file mkdir td2
file mkdir [file home]/td1
set td1name [file join [file dirname [file home]] [file tail [file home]] td1]
file attributes $td1name -permissions 0
file copy td2 [file home]/td1
} -returnCodes error -cleanup {
file attributes $td1name -permissions 0o755
file delete -force [file home]/td1
} -result "error copying \"td2\" to \"[file home]/td1/td2\": permission denied"
test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} -setup {
cleanup
} -constraints {unix notRoot} -body {
file mkdir [file home]/td1/td2
set td2name [file join [file dirname [file home]] [file tail [file home]] td1 td2]
file attributes $td2name -permissions 0
file copy [file home]/td1 td1
} -returnCodes error -cleanup {
file attributes $td2name -permissions 0o755
file delete -force [file home]/td1
} -result "error copying \"[file home]/td1\" to \"td1\": \"[file join $::env(HOME) td1 td2]\": permission denied"
test fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} -setup {
cleanup $tmpspace
} -constraints {notRoot xdev} -returnCodes error -body {
file mkdir td1/td2/td3
file mkdir [file join $tmpspace td1]
createfile [file join $tmpspace td1 tf1]
file rename -force td1 $tmpspace
|
| ︙ | ︙ | |||
737 738 739 740 741 742 743 |
createfile --
createfile -force
file delete -force -force -- -- -force
glob -- -- -force
} -result {no files matched glob patterns "-- -force"}
test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} \
| | | | | | 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 |
createfile --
createfile -force
file delete -force -force -- -- -force
glob -- -- -force
} -result {no files matched glob patterns "-- -force"}
test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} \
-constraints {unix notRoot knownBug tildeexpansion} -body {
# Labelled knownBug because it is dangerous [Bug: 3881]
file mkdir td1
file attr td1 -perm 0o40000
file rename ~$user td1
} -returnCodes error -cleanup {
file delete -force td1
} -result "error renaming \"~$user\" to \"td1/[file tail ~$user]\": permission denied"
test fCmd-8.2 {FileBasename: basename of ~user: argc == 1 && *path == ~} \
-constraints {unix notRoot} -body {
string equal [file tail ~$user] ~$user
} -result 1
test fCmd-8.3 {file copy and path translation: ensure correct error} -body {
file copy [file home] [file join this file doesnt exist]
} -returnCodes error -result [subst \
{error copying "[file home]" to "[file join this file doesnt exist]": no such file or directory}]
test fCmd-9.1 {file rename: comprehensive: EACCES} -setup {
cleanup
} -constraints {unix notRoot} -body {
file mkdir td1
file mkdir td2
file attr td2 -perm 0o40000
|
| ︙ | ︙ | |||
1494 1495 1496 1497 1498 1499 1500 1501 1502 |
file attributes tfa/dir -permissions 0o777
file delete -force tfa tfa2
} -result {1}
#
# Coverage tests for TclMkdirCmd()
#
test fCmd-15.1 {TclMakeDirsCmd: target filename translation failing} -setup {
set temp $::env(HOME)
| > > | | | 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 |
file attributes tfa/dir -permissions 0o777
file delete -force tfa tfa2
} -result {1}
#
# Coverage tests for TclMkdirCmd()
#
# ~ is no longer a special char. Need a test case where translation fails.
test fCmd-15.1 {TclMakeDirsCmd: target filename translation failing} -setup {
set temp $::env(HOME)
} -constraints {notRoot TODO} -body {
global env
unset env(HOME)
catch {file mkdir ~/tfa}
} -cleanup {
set ::env(HOME) $temp
} -result 1
#
# Can Tcl_SplitPath return argc == 0? If so them we need a test for that code.
#
test fCmd-15.2 {TclMakeDirsCmd - one directory} -setup {
catch {file delete -force -- tfa}
} -constraints {notRoot} -body {
file mkdir tfa
|
| ︙ | ︙ | |||
1595 1596 1597 1598 1599 1600 1601 1602 1603 |
} -result {1}
test fCmd-16.4 {accept zero files (TIP 323)} -body {
file delete
} -result {}
test fCmd-16.5 {accept zero files (TIP 323)} -body {
file delete --
} -result {}
test fCmd-16.6 {delete: source filename translation failing} -setup {
set temp $::env(HOME)
| > | | 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 |
} -result {1}
test fCmd-16.4 {accept zero files (TIP 323)} -body {
file delete
} -result {}
test fCmd-16.5 {accept zero files (TIP 323)} -body {
file delete --
} -result {}
# ~ is no longer a special char. Need a test case where translation fails.
test fCmd-16.6 {delete: source filename translation failing} -setup {
set temp $::env(HOME)
} -constraints {notRoot TODO} -body {
global env
unset env(HOME)
catch {file delete ~/tfa}
} -cleanup {
set ::env(HOME) $temp
} -result {1}
test fCmd-16.7 {remove a non-empty directory without -force} -setup {
|
| ︙ | ︙ | |||
2223 2224 2225 2226 2227 2228 2229 |
test fCmd-27.2 {TclFileAttrsCmd - Tcl_TranslateFileName fails} -setup {
set platform [testgetplatform]
} -constraints {testsetplatform} -body {
testsetplatform unix
file attributes ~_totally_bogus_user
} -returnCodes error -cleanup {
testsetplatform $platform
| | | 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 |
test fCmd-27.2 {TclFileAttrsCmd - Tcl_TranslateFileName fails} -setup {
set platform [testgetplatform]
} -constraints {testsetplatform} -body {
testsetplatform unix
file attributes ~_totally_bogus_user
} -returnCodes error -cleanup {
testsetplatform $platform
} -result {could not read "~_totally_bogus_user": no such file or directory}
test fCmd-27.3 {TclFileAttrsCmd - all attributes} -setup {
catch {file delete -force -- foo.tmp}
} -body {
createfile foo.tmp
file attributes foo.tmp
# Must be non-empty result
} -cleanup {
|
| ︙ | ︙ | |||
2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 |
set path $env(SystemDrive)/pagefile.sys
lappend r exists [file exists $path]
lappend r readable [file readable $path]
lappend r stat [catch {file stat $path a} e] $e
}
return $r
} -result {exists 1 readable 0 stat 0 {}}
# cleanup
cleanup
if {[testConstraint unix]} {
removeDirectory tcl[pid] /tmp
}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# fill-column: 78
# End:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 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 |
set path $env(SystemDrive)/pagefile.sys
lappend r exists [file exists $path]
lappend r readable [file readable $path]
lappend r stat [catch {file stat $path a} e] $e
}
return $r
} -result {exists 1 readable 0 stat 0 {}}
test fCmd-31.1 {file home} -body {
file home
} -result [file join $::env(HOME)]
test fCmd-31.2 {file home - obeys env} -setup {
set ::env(HOME) $::env(HOME)/xxx
} -cleanup {
set ::env(HOME) [file dirname $::env(HOME)]
} -body {
file home
} -result [file join $::env(HOME) xxx]
test fCmd-31.3 {file home - \ -> /} -constraints win -setup {
set saved $::env(HOME)
set ::env(HOME) C:\\backslash\\path
} -cleanup {
set ::env(HOME) $saved
} -body {
file home
} -result C:/backslash/path
test fCmd-31.4 {file home - error} -setup {
set saved $::env(HOME)
unset ::env(HOME)
} -cleanup {
set ::env(HOME) $saved
} -body {
file home
} -returnCodes error -result {couldn't find HOME environment variable to expand path}
test fCmd-31.5 {
file home - relative path. Following 8.x ~ expansion behavior, relative
paths are not made absolute
} -setup {
set saved $::env(HOME)
set ::env(HOME) relative/path
} -cleanup {
set ::env(HOME) $saved
} -body {
file home
} -result relative/path
test fCmd-31.6 {file home USER} -body {
# Note - as in 8.x this form does NOT necessarily give same result as
# env(HOME) even when user is current user. Assume result contains user
# name, else not sure how to check
file home $::tcl_platform(user)
} -match glob -result "*$::tcl_platform(user)*"
test fCmd-31.7 {file home UNKNOWNUSER} -body {
file home nosuchuser
} -returnCodes error -result {user "nosuchuser" doesn't exist}
test fCmd-31.8 {file home extra arg} -body {
file home $::tcl_platform(user) arg
} -returnCodes error -result {wrong # args: should be "file home ?user?"}
test fCmd-32.1 {file tildeexpand ~} -body {
file tildeexpand ~
} -result [file join $::env(HOME)]
test fCmd-32.2 {file tildeexpand ~ - obeys env} -setup {
set ::env(HOME) $::env(HOME)/xxx
} -cleanup {
set ::env(HOME) [file dirname $::env(HOME)]
} -body {
file tildeexpand ~
} -result [file join $::env(HOME) xxx]
test fCmd-32.3 {file tildeexpand ~ - error} -setup {
set saved $::env(HOME)
unset ::env(HOME)
} -cleanup {
set ::env(HOME) $saved
} -body {
file tildeexpand ~
} -returnCodes error -result {couldn't find HOME environment variable to expand path}
test fCmd-32.4 {
file tildeexpand ~ - relative path. Following 8.x ~ expansion behavior, relative
paths are not made absolute
} -setup {
set saved $::env(HOME)
set ::env(HOME) relative/path
} -cleanup {
set ::env(HOME) $saved
} -body {
file tildeexpand ~
} -result relative/path
test fCmd-32.5 {file tildeexpand ~USER} -body {
# Note - as in 8.x this form does NOT necessarily give same result as
# env(HOME) even when user is current user. Assume result contains user
# name, else not sure how to check
file tildeexpand ~$::tcl_platform(user)
} -match glob -result "*$::tcl_platform(user)*"
test fCmd-32.6 {file tildeexpand ~UNKNOWNUSER} -body {
file tildeexpand ~nosuchuser
} -returnCodes error -result {user "nosuchuser" doesn't exist}
test fCmd-32.7 {file tildeexpand ~extra arg} -body {
file tildeexpand ~ arg
} -returnCodes error -result {wrong # args: should be "file tildeexpand path"}
test fCmd-32.8 {file tildeexpand ~/path} -body {
file tildeexpand ~/foo
} -result [file join $::env(HOME)/foo]
test fCmd-32.9 {file tildeexpand ~USER/bar} -body {
# Note - as in 8.x this form does NOT necessarily give same result as
# env(HOME) even when user is current user. Assume result contains user
# name, else not sure how to check
file tildeexpand ~$::tcl_platform(user)/bar
} -match glob -result "*$::tcl_platform(user)*/bar"
test fCmd-32.10 {file tildeexpand ~UNKNOWNUSER} -body {
file tildeexpand ~nosuchuser/foo
} -returnCodes error -result {user "nosuchuser" doesn't exist}
test fCmd-32.11 {file tildeexpand /~/path} -body {
file tildeexpand /~/foo
} -result /~/foo
test fCmd-32.12 {file tildeexpand /~user/path} -body {
file tildeexpand /~$::tcl_platform(user)/foo
} -result /~$::tcl_platform(user)/foo
test fCmd-32.13 {file tildeexpand ./~} -body {
file tildeexpand ./~
} -result ./~
test fCmd-32.14 {file tildeexpand relative/path} -body {
file tildeexpand relative/path
} -result relative/path
test fCmd-32.15 {file tildeexpand ~\\path} -body {
file tildeexpand ~\\foo
} -constraints win -result [file join $::env(HOME)/foo]
test fCmd-32.16 {file tildeexpand ~USER\\bar} -body {
# Note - as in 8.x this form does NOT necessarily give same result as
# env(HOME) even when user is current user. Assume result contains user
# name, else not sure how to check
file tildeexpand ~$::tcl_platform(user)\\bar
} -constraints win -match glob -result "*$::tcl_platform(user)*/bar"
# cleanup
cleanup
if {[testConstraint unix]} {
removeDirectory tcl[pid] /tmp
}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# fill-column: 78
# End:
|
Changes to tests/fileName.test.
| ︙ | ︙ | |||
67 68 69 70 71 72 73 |
test filename-1.4 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype c:/foo
} relative
test filename-1.5 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype ~
| | | | | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 |
test filename-1.4 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype c:/foo
} relative
test filename-1.5 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype ~
} relative
test filename-1.6 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype ~/foo
} relative
test filename-1.7 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype ~foo
} relative
test filename-1.8 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype ./~foo
} relative
test filename-3.1 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
|
| ︙ | ︙ | |||
132 133 134 135 136 137 138 |
test filename-3.12 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype //foo/bar
} absolute
test filename-3.13 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype ~foo
| | | | | 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 |
test filename-3.12 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype //foo/bar
} absolute
test filename-3.13 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype ~foo
} relative
test filename-3.14 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype ~
} relative
test filename-3.15 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype ~/foo
} relative
test filename-3.16 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype ./~foo
} relative
test filename-4.1 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
|
| ︙ | ︙ | |||
209 210 211 212 213 214 215 |
test filename-4.15 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ~foo
} {~foo}
test filename-4.16 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ~foo/~bar
| | | | 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 |
test filename-4.15 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ~foo
} {~foo}
test filename-4.16 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ~foo/~bar
} {~foo ~bar}
test filename-4.17 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ~foo/~bar/~baz
} {~foo ~bar ~baz}
test filename-4.18 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split foo/bar~/baz
} {foo bar~ baz}
if {[testConstraint testsetplatform]} {
testsetplatform $platform
}
|
| ︙ | ︙ | |||
353 354 355 356 357 358 359 |
test filename-6.26 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split ~foo
} {~foo}
test filename-6.27 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split ~foo/~bar
| | | | | 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 |
test filename-6.26 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split ~foo
} {~foo}
test filename-6.27 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split ~foo/~bar
} {~foo ~bar}
test filename-6.28 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split ~foo/~bar/~baz
} {~foo ~bar ~baz}
test filename-6.29 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split foo/bar~/baz
} {foo bar~ baz}
test filename-6.30 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split c:~foo
} {c: ~foo}
test filename-7.1 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join / a
} {/a}
test filename-7.2 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
|
| ︙ | ︙ | |||
410 411 412 413 414 415 416 |
test filename-7.10 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join ~ a
} {~/a}
test filename-7.11 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join ~a ~b
| | | | | | 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 |
test filename-7.10 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join ~ a
} {~/a}
test filename-7.11 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join ~a ~b
} {~a/~b}
test filename-7.12 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join ./~a b
} {./~a/b}
test filename-7.13 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join ./~a ~b
} {./~a/~b}
test filename-7.14 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join ./~a ./~b
} {./~a/./~b}
test filename-7.15 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join a . b
} {a/./b}
test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join a . ./~b
} {a/././~b}
test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join //a b
} "/a/b"
test filename-7.18 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join /// a b
|
| ︙ | ︙ | |||
486 487 488 489 490 491 492 |
test filename-9.10 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join ~/~foo
} {~/~foo}
test filename-9.11 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join ~ ./~foo
| | | | 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 |
test filename-9.10 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join ~/~foo
} {~/~foo}
test filename-9.11 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join ~ ./~foo
} {~/./~foo}
test filename-9.12 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join / ~foo
} {/~foo}
test filename-9.13 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join ./a/ b c
} {./a/b/c}
test filename-9.14 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join ./~a/ b c
|
| ︙ | ︙ | |||
596 597 598 599 600 601 602 |
set temp $env(HOME)
} -constraints {testsetplatform testtranslatefilename} -body {
set env(HOME) "/home/test"
testsetplatform unix
testtranslatefilename ~/foo
} -cleanup {
set env(HOME) $temp
| | | | | | | | | | | | | | 596 597 598 599 600 601 602 603 604 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 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 |
set temp $env(HOME)
} -constraints {testsetplatform testtranslatefilename} -body {
set env(HOME) "/home/test"
testsetplatform unix
testtranslatefilename ~/foo
} -cleanup {
set env(HOME) $temp
} -result {~/foo}
test filename-10.7 {Tcl_TranslateFileName} -setup {
global env
set temp $env(HOME)
} -constraints {testsetplatform testtranslatefilename} -body {
unset env(HOME)
testsetplatform unix
testtranslatefilename ~/foo
} -cleanup {
set env(HOME) $temp
} -result {~/foo}
test filename-10.8 {Tcl_TranslateFileName} -setup {
global env
set temp $env(HOME)
} -constraints {testsetplatform testtranslatefilename} -body {
set env(HOME) "/home/test"
testsetplatform unix
testtranslatefilename ~
} -cleanup {
set env(HOME) $temp
} -result {~}
test filename-10.9 {Tcl_TranslateFileName} -setup {
global env
set temp $env(HOME)
} -constraints {testsetplatform testtranslatefilename} -body {
set env(HOME) "/home/test/"
testsetplatform unix
testtranslatefilename ~
} -cleanup {
set env(HOME) $temp
} -result {~}
test filename-10.10 {Tcl_TranslateFileName} -setup {
global env
set temp $env(HOME)
} -constraints {testsetplatform testtranslatefilename} -body {
set env(HOME) "/home/test/"
testsetplatform unix
testtranslatefilename ~/foo
} -cleanup {
set env(HOME) $temp
} -result {~/foo}
test filename-10.17 {Tcl_TranslateFileName} -setup {
global env
set temp $env(HOME)
} -constraints {testsetplatform testtranslatefilename} -body {
set env(HOME) "\\home\\"
testsetplatform windows
testtranslatefilename ~/foo
} -cleanup {
set env(HOME) $temp
} -result {~\foo}
test filename-10.18 {Tcl_TranslateFileName} -setup {
global env
set temp $env(HOME)
} -constraints {testsetplatform testtranslatefilename} -body {
set env(HOME) "\\home\\"
testsetplatform windows
testtranslatefilename ~/foo\\bar
} -cleanup {
set env(HOME) $temp
} -result {~\foo\bar}
test filename-10.19 {Tcl_TranslateFileName} -setup {
global env
set temp $env(HOME)
} -constraints {testsetplatform testtranslatefilename} -body {
set env(HOME) "c:"
testsetplatform windows
testtranslatefilename ~/foo
} -cleanup {
set env(HOME) $temp
} -result {~\foo}
test filename-10.20 {Tcl_TranslateFileName} -body {
testtranslatefilename ~blorp/foo
} -constraints {testtranslatefilename testtranslatefilename} \
-result {~blorp\foo}
test filename-10.21 {Tcl_TranslateFileName} -setup {
global env
set temp $env(HOME)
} -constraints {testsetplatform testtranslatefilename} -body {
set env(HOME) "c:\\"
testsetplatform windows
testtranslatefilename ~/foo
} -cleanup {
set env(HOME) $temp
} -result {~\foo}
test filename-10.22 {Tcl_TranslateFileName} -body {
testsetplatform windows
testtranslatefilename foo//bar
} -constraints {testsetplatform testtranslatefilename} -result {foo\bar}
if {[testConstraint testsetplatform]} {
testsetplatform $platform
}
|
| ︙ | ︙ | |||
709 710 711 712 713 714 715 |
} -result {bad option "-gorp": must be -directory, -join, -nocomplain, -path, -tails, -types, or --}
test filename-11.3 {Tcl_GlobCmd} -body {
glob -nocomplai
} -result {}
test filename-11.4 {Tcl_GlobCmd} -body {
glob -nocomplain
} -result {}
| | > | | | | | | | | | | | | | | 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 |
} -result {bad option "-gorp": must be -directory, -join, -nocomplain, -path, -tails, -types, or --}
test filename-11.3 {Tcl_GlobCmd} -body {
glob -nocomplai
} -result {}
test filename-11.4 {Tcl_GlobCmd} -body {
glob -nocomplain
} -result {}
test filename-11.5 {Tcl_GlobCmd} -body {
# Should not error out because of ~
catch {glob -nocomplain * ~xyqrszzz}
} -result 0
test filename-11.6 {Tcl_GlobCmd} -returnCodes error -body {
glob ~xyqrszzz
} -result {no files matched glob pattern "~xyqrszzz"}
test filename-11.7 {Tcl_GlobCmd} -returnCodes error -body {
glob -- -nocomplain
} -result {no files matched glob pattern "-nocomplain"}
test filename-11.8 {Tcl_GlobCmd} -body {
glob -nocomplain -- -nocomplain
} -result {}
test filename-11.9 {Tcl_GlobCmd} -constraints {testsetplatform} -body {
testsetplatform unix
glob ~\\xyqrszzz/bar
} -returnCodes error -result {no files matched glob pattern "~\xyqrszzz/bar"}
test filename-11.10 {Tcl_GlobCmd} -constraints {testsetplatform} -body {
testsetplatform unix
glob -nocomplain ~\\xyqrszzz/bar
} -result {}
test filename-11.11 {Tcl_GlobCmd} -constraints {testsetplatform} -body {
testsetplatform unix
glob ~xyqrszzz\\/\\bar
} -returnCodes error -result {no files matched glob pattern "~xyqrszzz\/\bar"}
test filename-11.12 {Tcl_GlobCmd} -constraints {testsetplatform} -setup {
testsetplatform unix
set home $env(HOME)
} -body {
unset env(HOME)
glob ~/*
} -returnCodes error -cleanup {
set env(HOME) $home
} -result {no files matched glob pattern "~/*"}
if {[testConstraint testsetplatform]} {
testsetplatform $platform
}
test filename-11.13 {Tcl_GlobCmd} -body {
file join [lindex [glob ~] 0]
} -returnCodes error -result {no files matched glob pattern "~"}
set oldpwd [pwd]
set oldhome $env(HOME)
catch {cd [makeDirectory tcl[pid]]}
set env(HOME) [pwd]
file delete -force globTest
file mkdir globTest/a1/b1
file mkdir globTest/a1/b2
file mkdir globTest/a2/b3
file mkdir globTest/a3
touch globTest/x1.c
touch globTest/y1.c
touch globTest/z1.c
touch "globTest/weird name.c"
touch globTest/a1/b1/x2.c
touch globTest/a1/b2/y2.c
touch globTest/.1
touch globTest/x,z1.c
test filename-11.14 {Tcl_GlobCmd} -body {
glob ~/globTest
} -returnCodes error -result {no files matched glob pattern "~/globTest"}
test filename-11.15 {Tcl_GlobCmd} -body {
glob ~\\/globTest
} -returnCodes error -result {no files matched glob pattern "~\/globTest"}
test filename-11.16 {Tcl_GlobCmd} {
glob globTest
} {globTest}
set globname "globTest"
set horribleglobname "glob\[\{Test"
set tildeglobname "./~test.txt"
|
| ︙ | ︙ | |||
1248 1249 1250 1251 1252 1253 1254 |
lsort [glob globTest/*/]
} {globTest/a1/ globTest/a2/ globTest/a3/}
test filename-14.17 {asterisks, question marks, and brackets} -setup {
global env
set temp $env(HOME)
} -body {
set env(HOME) [file join $env(HOME) globTest]
| | | 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 |
lsort [glob globTest/*/]
} {globTest/a1/ globTest/a2/ globTest/a3/}
test filename-14.17 {asterisks, question marks, and brackets} -setup {
global env
set temp $env(HOME)
} -body {
set env(HOME) [file join $env(HOME) globTest]
glob [file home]/z*
} -cleanup {
set env(HOME) $temp
} -result [list [file join $env(HOME) globTest z1.c]]
test filename-14.18 {asterisks, question marks, and brackets} {unixOrWin} {
lsort [glob globTest/*.c goo/*]
} {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.20 {asterisks, question marks, and brackets} {
|
| ︙ | ︙ | |||
1345 1346 1347 1348 1349 1350 1351 |
test filename-15.4 {unix specific no complain: no errors, good result} \
{unix nonPortable} {
# test fails because if an error occurs, the interp's result is reset...
# or you don't run at scriptics where the outser and welch users exists
glob -nocomplain ~ouster ~foo ~welch
} {/home/ouster /home/welch}
test filename-15.4.1 {no complain: errors, sequencing} {
| | < < > | < | < < < | < < < < | | | | 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 |
test filename-15.4 {unix specific no complain: no errors, good result} \
{unix nonPortable} {
# test fails because if an error occurs, the interp's result is reset...
# or you don't run at scriptics where the outser and welch users exists
glob -nocomplain ~ouster ~foo ~welch
} {/home/ouster /home/welch}
test filename-15.4.1 {no complain: errors, sequencing} {
# ~xxx no longer expanded so errors about unknown users should not occur
list [catch {glob -nocomplain ~wontexist ~blahxyz ~} res1] $res1 \
[catch {glob -nocomplain ~ ~blahxyz ~wontexist} res2] $res2
} {0 {} 0 {}}
test filename-15.4.2 {no complain: errors, sequencing} -body {
# test used to fail because if an error occurs, the interp's result is
# reset...
list [list [catch {glob -nocomplain ~wontexist *} res1] $res1] \
[list [catch {glob -nocomplain * ~wontexist} res2] $res2]
} -match compareWords -result equal
test filename-15.5 {unix specific globbing} {unix nonPortable} {
glob ~ouster/.csh*
} "/home/ouster/.cshrc"
# 15.6 removed. It checked if glob ~ returned valid information if
# home directory contained glob chars. Since ~ expansion is no longer
# supported, the test was meaningless
test filename-15.7 {glob tilde} -body {
glob ~
} -returnCodes error -result {no files matched glob pattern "~"}
test filename-15.8 {win and unix specific globbing} -constraints {unixOrWin} -setup {
global env
set temp $env(HOME)
} -body {
touch $env(HOME)/globTest/anyname
set env(HOME) $env(HOME)/globTest/anyname
glob ~
} -cleanup {
set env(HOME) $temp
catch {file delete -force $env(HOME)/globTest/anyname}
} -returnCodes error -result {no files matched glob pattern "~"}
# The following tests are only valid for Windows systems.
set oldDir [pwd]
if {[testConstraint win]} {
cd c:/
file delete -force globTest
file mkdir globTest
|
| ︙ | ︙ | |||
1562 1563 1564 1565 1566 1567 1568 |
removeFile test $d
removeDirectory ./~foo $dd
removeDirectory isolate
} -result ~foo/test
test fileName-20.6 {Bug 2837800} -setup {
# Recall that we have $env(HOME) set so that references
# to ~ point to [temporaryDirectory]
| | | 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 |
removeFile test $d
removeDirectory ./~foo $dd
removeDirectory isolate
} -result ~foo/test
test fileName-20.6 {Bug 2837800} -setup {
# Recall that we have $env(HOME) set so that references
# to ~ point to [temporaryDirectory]
makeFile {} test [file home]
set dd [makeDirectory isolate]
set d [makeDirectory ./~ $dd]
set savewd [pwd]
cd $dd
} -body {
glob -nocomplain */test
} -cleanup {
|
| ︙ | ︙ | |||
1598 1599 1600 1601 1602 1603 1604 |
makeFile {} ./~test $d
} -body {
file tail [lindex [glob -nocomplain isolate/*] 0]
} -cleanup {
removeFile ./~test $d
removeDirectory isolate
cd $savewd
| | < < < < < < < < < < < < | | | | | 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 |
makeFile {} ./~test $d
} -body {
file tail [lindex [glob -nocomplain isolate/*] 0]
} -cleanup {
removeFile ./~test $d
removeDirectory isolate
cd $savewd
} -result ~test
test fileName-20.10 {globbing for special chars} -setup {
set s [makeDirectory sub [file home]]
makeFile {} fileName-20.10 $s
set d [makeDirectory isolate]
set savewd [pwd]
cd $d
} -body {
glob -nocomplain -directory [file home] -join * fileName-20.10
} -cleanup {
cd $savewd
removeDirectory isolate
removeFile fileName-20.10 $s
removeDirectory sub [file home]
} -result [file home]/sub/fileName-20.10
# cleanup
catch {file delete -force C:/globTest}
cd [temporaryDirectory]
file delete -force globTest
cd $oldpwd
catch {removeDirectory tcl[pid]}
|
| ︙ | ︙ |
Changes to tests/fileSystem.test.
| ︙ | ︙ | |||
263 264 265 266 267 268 269 | file delete -force dir2.link file delete -force link.file dir.link file delete -force dir2 file delete -force [file join dir.dir dirinside.link] removeFile [file join dir.dir inside.file] removeDirectory [file join dir.dir dirinside.dir] removeDirectory dir.dir | | > > | | | < < < | 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 |
file delete -force dir2.link
file delete -force link.file dir.link
file delete -force dir2
file delete -force [file join dir.dir dirinside.link]
removeFile [file join dir.dir inside.file]
removeDirectory [file join dir.dir dirinside.dir]
removeDirectory dir.dir
test filesystem-1.30 {
normalisation of nonexistent user - verify no tilde expansion
} -body {
file normalize ~noonewiththisname
} -result [file join [pwd] ~noonewiththisname]
test filesystem-1.30.1 {normalisation of existing user} -body {
file normalize ~$::tcl_platform(user)
} -result [file join [pwd] ~$::tcl_platform(user)]
test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} {
testsetplatform unix
file normalize /foo/../bar
} {/bar}
test filesystem-1.32 {link normalisation: link near filesystem root} {testsetplatform} {
testsetplatform unix
file normalize /../bar
|
| ︙ | ︙ | |||
469 470 471 472 473 474 475 |
testfilesystem 1
set filesystemReport {}
catch {glob *}
testfilesystem 0
return $filesystemReport
} -match glob -result {*{matchindirectory *}*}
| > | > > | 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 |
testfilesystem 1
set filesystemReport {}
catch {glob *}
testfilesystem 0
return $filesystemReport
} -match glob -result {*{matchindirectory *}*}
# This test is meaningless if there is no tilde expansion
test filesystem-5.1 {cache and ~} -constraints {
testfilesystem tildeexpansion
} -setup {
set orig $::env(HOME)
} -body {
set ::env(HOME) /foo/bar/blah
set testdir ~
set res1 "Parent of ~ (/foo/bar/blah) is [file dirname $testdir]"
set ::env(HOME) /a/b/c
set res2 "Parent of ~ (/a/b/c) is [file dirname $testdir]"
|
| ︙ | ︙ | |||
935 936 937 938 939 940 941 |
lappend res $file
lappend res [file exists $file] [catch {file tail $file} r] $r
lappend res [catch {file tail $file} r] $r
} -cleanup {
cd [tcltest::temporaryDirectory]
file delete -force tilde
cd $origdir
| | | | | 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 |
lappend res $file
lappend res [file exists $file] [catch {file tail $file} r] $r
lappend res [catch {file tail $file} r] $r
} -cleanup {
cd [tcltest::temporaryDirectory]
file delete -force tilde
cd $origdir
} -result {1 0 ~testNotExist ~testNotExist 1 0 ~testNotExist 0 ~testNotExist}
test filesystem-9.8 {path objects and glob and file tail and tilde} -setup {
set res {}
set origdir [pwd]
cd [tcltest::temporaryDirectory]
} -body {
file mkdir tilde
close [open tilde/~testNotExist w]
cd tilde
set file1 [lindex [glob *test*] 0]
set file2 "~testNotExist"
lappend res $file1 $file2
lappend res [catch {file tail $file1} r] $r
lappend res [catch {file tail $file2} r] $r
} -cleanup {
cd [tcltest::temporaryDirectory]
file delete -force tilde
cd $origdir
} -result {~testNotExist ~testNotExist 0 ~testNotExist 0 ~testNotExist}
test filesystem-9.9 {path objects and glob and file tail and tilde} -setup {
set res {}
set origdir [pwd]
cd [tcltest::temporaryDirectory]
} -body {
file mkdir tilde
close [open tilde/~testNotExist w]
cd tilde
set file1 [lindex [glob *test*] 0]
set file2 "~testNotExist"
lappend res [catch {file exists $file1} r] $r
lappend res [catch {file exists $file2} r] $r
lappend res [string equal $file1 $file2]
} -cleanup {
cd [tcltest::temporaryDirectory]
file delete -force tilde
cd $origdir
} -result {0 1 0 1 1}
# ----------------------------------------------------------------------
test filesystem-10.1 {Bug 3414754} {
string match */ [file join [pwd] foo/]
} 0
|
| ︙ | ︙ |
Changes to tests/get.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 | } ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] testConstraint testgetint [llength [info commands testgetint]] testConstraint testdoubleobj [llength [info commands testdoubleobj]] | < | | | | | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
}
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testgetint [llength [info commands testgetint]]
testConstraint testdoubleobj [llength [info commands testdoubleobj]]
testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
test get-1.1 {Tcl_GetInt procedure} testgetint {
testgetint 44 { 22}
} {66}
test get-1.2 {Tcl_GetInt procedure} testgetint {
testgetint 44 -3
} {41}
test get-1.3 {Tcl_GetInt procedure} testgetint {
testgetint 44 +8
} {52}
test get-1.4 {Tcl_GetInt procedure} testgetint {
list [catch {testgetint 44 foo} msg] $msg
} {1 {expected integer but got "foo"}}
test get-1.5 {Tcl_GetInt procedure} testgetint {
list [catch {testgetint 44 {16 }} msg] $msg
} {0 60}
test get-1.6 {Tcl_GetInt procedure} testgetint {
list [catch {testgetint 44 {16 x}} msg] $msg
} {1 {expected integer but got "16 x"}}
test get-1.7 {Tcl_GetInt procedure} testgetint {
list [catch {testgetint 44 18446744073709551616} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test get-1.8 {Tcl_GetInt procedure} {testgetint longIs64bit} {
testgetint 18446744073709551614
} {-2}
test get-1.9 {Tcl_GetInt procedure} {testgetint longIs64bit} {
testgetint +18446744073709551614
} {-2}
test get-1.10 {Tcl_GetInt procedure} testgetint {
list [catch {testgetint -18446744073709551614} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test get-1.11 {Tcl_GetInt procedure} testgetint {
list [catch {testgetint 44 4294967296} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test get-1.12 {Tcl_GetInt procedure} testgetint {
list [catch {testgetint 4294967294} msg] $msg
} {0 -2}
test get-1.13 {Tcl_GetInt procedure} testgetint {
list [catch {testgetint +4294967294} msg] $msg
} {0 -2}
test get-1.14 {Tcl_GetInt procedure} testgetint {
list [catch {testgetint -4294967294} msg] $msg
} {1 {integer value too large to represent}}
test get-2.1 {Tcl_GetInt procedure} {
format %g 1.23
} {1.23}
test get-2.2 {Tcl_GetInt procedure} {
|
| ︙ | ︙ |
Changes to tests/http.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
| | < < < < < < < < < < < < < | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
package require http 2.10
proc bgerror {args} {
global errorInfo
puts stderr "http.test bgerror"
puts stderr [join $args]
puts stderr $errorInfo
}
|
| ︙ | ︙ | |||
73 74 75 76 77 78 79 80 81 82 83 |
# Let the OS pick the port; that's much more flexible
if {[catch {httpd_init 0} listen]} {
puts "Cannot start http server, http test skipped"
catch {unset port}
return
}
}
test http-1.1 {http::config} {
http::config -useragent UserAgent
http::config
| > > > > > > > > > > > > > > > > > > > > | | | | 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 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 |
# Let the OS pick the port; that's much more flexible
if {[catch {httpd_init 0} listen]} {
puts "Cannot start http server, http test skipped"
catch {unset port}
return
}
}
if {![info exists ThreadLevel]} {
if {[catch {package require Thread}] == 0} {
set ValueRange {0 1 2}
} else {
set ValueRange {0 1}
}
# For each value of ThreadLevel, source this file recursively in the
# same interpreter.
foreach ThreadLevel $ValueRange {
source [info script]
}
catch {unset ThreadLevel}
catch {unset ValueRange}
return
}
catch {puts "==== Test with ThreadLevel $ThreadLevel ===="}
http::config -threadlevel $ThreadLevel
test http-1.1 {http::config} {
http::config -useragent UserAgent
http::config
} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -threadlevel $ThreadLevel -urlencoding utf-8 -useragent UserAgent -zip 1]
test http-1.2 {http::config} {
http::config -proxyfilter
} http::ProxyRequired
test http-1.3 {http::config} {
catch {http::config -junk}
} 1
test http-1.4 {http::config} {
set savedconf [http::config]
http::config -proxyhost nowhere.come -proxyport 8080 \
-proxyfilter myFilter -useragent "Tcl Test Suite" \
-urlencoding iso8859-1
set x [http::config]
http::config {*}$savedconf
set x
} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -threadlevel $ThreadLevel -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1]
test http-1.5 {http::config} -returnCodes error -body {
http::config -proxyhost {} -junk 8080
} -result {Unknown option -junk, must be: -accept, -cookiejar, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -threadlevel, -urlencoding, -useragent, -zip}
test http-1.6 {http::config} -setup {
set oldenc [http::config -urlencoding]
} -body {
set enc [list [http::config -urlencoding]]
http::config -urlencoding iso8859-1
lappend enc [http::config -urlencoding]
} -cleanup {
|
| ︙ | ︙ | |||
134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 |
test http-2.8 {http::CharsetToEncoding} {
http::CharsetToEncoding latin4
} binary
test http-3.1 {http::geturl} -returnCodes error -body {
http::geturl -bogus flag
} -result {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate}
test http-3.2 {http::geturl} -returnCodes error -body {
http::geturl http:junk
} -result {Unsupported URL: http:junk}
set url //${::HOST}:$port
set badurl //${::HOST}:[expr {$port+1}]
test http-3.3 {http::geturl} -body {
set token [http::geturl $url]
http::data $token
} -cleanup {
http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET /</h2>
</body></html>"
set tail /a/b/c
set url //${::HOST}:$port/a/b/c
set fullurl HTTP://user:pass@${::HOST}:$port/a/b/c
set binurl //${::HOST}:$port/binary
set xmlurl //${::HOST}:$port/xml
set posturl //${::HOST}:$port/post
set badposturl //${::HOST}:$port/droppost
set authorityurl //${::HOST}:$port
set ipv6url http://\[::1\]:$port/
test http-3.4 {http::geturl} -body {
set token [http::geturl $url]
http::data $token
} -cleanup {
http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
| > > > > | 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 |
test http-2.8 {http::CharsetToEncoding} {
http::CharsetToEncoding latin4
} binary
test http-3.1 {http::geturl} -returnCodes error -body {
http::geturl -bogus flag
} -result {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate}
test http-3.2 {http::geturl} -returnCodes error -body {
http::geturl http:junk
} -result {Unsupported URL: http:junk}
set url //${::HOST}:$port
set badurl //${::HOST}:[expr {$port+1}]
test http-3.3 {http::geturl} -body {
set token [http::geturl $url]
http::data $token
} -cleanup {
http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET /</h2>
</body></html>"
set tail /a/b/c
set url //${::HOST}:$port/a/b/c
set fullurl HTTP://user:pass@${::HOST}:$port/a/b/c
set binurl //${::HOST}:$port/binary
set xmlurl //${::HOST}:$port/xml
set posturl //${::HOST}:$port/post
set badposturl //${::HOST}:$port/droppost
set authorityurl //${::HOST}:$port
set ipv6url http://\[::1\]:$port/
test http-3.4 {http::geturl} -body {
set token [http::geturl $url]
http::data $token
} -cleanup {
http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
|
| ︙ | ︙ | |||
458 459 460 461 462 463 464 |
# Bug 838e99a76d
test http-3.33 {http::geturl application/xml is text} -body {
set token [http::geturl "$xmlurl"]
scan [http::data $token] "<%\[^>]>%c<%\[^>]>"
} -cleanup {
catch { http::cleanup $token }
} -result {test 4660 /test}
| | | | > > > | 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 |
# Bug 838e99a76d
test http-3.33 {http::geturl application/xml is text} -body {
set token [http::geturl "$xmlurl"]
scan [http::data $token] "<%\[^>]>%c<%\[^>]>"
} -cleanup {
catch { http::cleanup $token }
} -result {test 4660 /test}
test http-3.34 {http::geturl -headers not a list} -returnCodes error -body {
http::geturl http://test/t -headers \"
} -result {Bad value for -headers ("), must be list}
test http-3.35 {http::geturl -headers not even number of elements} -returnCodes error -body {
http::geturl http://test/t -headers {List Length 3}
} -result {Bad value for -headers (List Length 3), number of list elements must be even}
test http-4.1 {http::Event} -body {
set token [http::geturl $url -keepalive 0]
upvar #0 $token data
array set meta $data(meta)
expr {($data(totalsize) == $meta(Content-Length))}
} -cleanup {
|
| ︙ | ︙ | |||
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 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 |
} -result {HTTP/1.0 200 Data follows}
test http-4.10 {http::Event} -body {
set token [http::geturl $url -progress myProgress]
http::size $token
} -cleanup {
http::cleanup $token
} -result {111}
# Timeout cases
# Short timeout to working server (the test server). This lets us try a
# reset during the connection.
test http-4.11 {http::Event} -body {
set token [http::geturl $url -timeout 1 -keepalive 0 -command \#]
http::reset $token
http::status $token
} -cleanup {
http::cleanup $token
} -result {reset}
# Longer timeout with reset.
test http-4.12 {http::Event} -body {
set token [http::geturl $url/?timeout=10 -keepalive 0 -command \#]
http::reset $token
http::status $token
} -cleanup {
http::cleanup $token
} -result {reset}
# Medium timeout to working server that waits even longer. The timeout
# hits while waiting for a reply.
test http-4.13 {http::Event} -body {
set token [http::geturl $url?timeout=30 -keepalive 0 -timeout 10 -command \#]
http::wait $token
http::status $token
} -cleanup {
http::cleanup $token
} -result {timeout}
# Longer timeout to good host, bad port, gets an error after the
# connection "completes" but the socket is bad.
test http-4.14 {http::Event} -body {
set token [http::geturl $badurl/?timeout=10 -timeout 10000 -command \#]
if {$token eq ""} {
error "bogus return from http::geturl"
}
http::wait $token
lindex [http::error $token] 0
} -cleanup {
catch {http::cleanup $token}
} -result {connect failed connection refused}
# Bogus host
test http-4.15 {http::Event} -body {
# This test may fail if you use a proxy server. That is to be
# expected and is not a problem with Tcl.
set token [http::geturl //not_a_host.tcl.tk -timeout 3000 -command \#]
http::wait $token
| > > > > > | | > | 578 579 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 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 |
} -result {HTTP/1.0 200 Data follows}
test http-4.10 {http::Event} -body {
set token [http::geturl $url -progress myProgress]
http::size $token
} -cleanup {
http::cleanup $token
} -result {111}
# Timeout cases
# Short timeout to working server (the test server). This lets us try a
# reset during the connection.
test http-4.11 {http::Event} -body {
set token [http::geturl $url -timeout 1 -keepalive 0 -command \#]
http::reset $token
http::status $token
} -cleanup {
http::cleanup $token
} -result {reset}
# Longer timeout with reset.
test http-4.12 {http::Event} -body {
set token [http::geturl $url/?timeout=10 -keepalive 0 -command \#]
http::reset $token
http::status $token
} -cleanup {
http::cleanup $token
} -result {reset}
# Medium timeout to working server that waits even longer. The timeout
# hits while waiting for a reply.
test http-4.13 {http::Event} -body {
set token [http::geturl $url?timeout=30 -keepalive 0 -timeout 10 -command \#]
http::wait $token
http::status $token
} -cleanup {
http::cleanup $token
} -result {timeout}
# Longer timeout to good host, bad port, gets an error after the
# connection "completes" but the socket is bad.
test http-4.14 {http::Event} -body {
set token [http::geturl $badurl/?timeout=10 -timeout 10000 -command \#]
if {$token eq ""} {
error "bogus return from http::geturl"
}
http::wait $token
lindex [http::error $token] 0
} -cleanup {
catch {http::cleanup $token}
} -result {connect failed connection refused}
# Bogus host
test http-4.15 {http::Event} -body {
# This test may fail if you use a proxy server. That is to be
# expected and is not a problem with Tcl.
set token [http::geturl //not_a_host.tcl.tk -timeout 3000 -command \#]
http::wait $token
set result "[http::status $token] -- [lindex [http::error $token] 0]"
# error codes vary among platforms.
} -cleanup {
catch {http::cleanup $token}
} -match glob -result "error -- couldn't open socket*"
test http-4.16 {Leak with Close vs Keepalive (bug [6ca52aec14]} -setup {
proc list-difference {l1 l2} {
lmap item $l2 {if {$item in $l1} continue; set item}
}
} -body {
set before [chan names]
set token [http::geturl $url -headers {X-Connection keep-alive}]
|
| ︙ | ︙ | |||
682 683 684 685 686 687 688 |
} -cleanup {
http::config -urlencoding $enc
} -result {unknown encoding ""}
test http-7.4 {http::formatQuery} -setup {
set enc [http::config -urlencoding]
} -body {
# this would be reverting to http <=2.4 behavior w/o errors
| | | 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 |
} -cleanup {
http::config -urlencoding $enc
} -result {unknown encoding ""}
test http-7.4 {http::formatQuery} -setup {
set enc [http::config -urlencoding]
} -body {
# this would be reverting to http <=2.4 behavior w/o errors
# with Tcl 8.x (unknown chars become '?'), generating a
# proper exception with Tcl 9.0
http::config -urlencoding "iso8859-1"
http::mapReply "∈"
} -cleanup {
http::config -urlencoding $enc
} -errorCode {TCL ENCODING ILLEGALSEQUENCE 0} -result {unexpected character at index 0: 'U+002208'}
|
| ︙ | ︙ |
Changes to tests/http11.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
package require http 2.10
# start the server
variable httpd_output
proc create_httpd {} {
proc httpd_read {chan} {
variable httpd_output
if {[gets $chan line] >= 0} {
|
| ︙ | ︙ | |||
83 84 85 86 87 88 89 90 91 92 93 94 95 96 |
if {$crc ne $chk} {
return "crc32 mismatch: $crc ne $chk"
}
return "ok"
}
makeFile "<html><head><title>test</title></head><body><p>this is a test</p>\n[string repeat {<p>This is a tcl test file.</p>} 4192]\n</body></html>" testdoc.html
# -------------------------------------------------------------------------
test http11-1.0 "normal request for document " -setup {
variable httpd [create_httpd]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html -timeout 10000]
| > > > > > > > > > > > > > > > > > > > > | 83 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 |
if {$crc ne $chk} {
return "crc32 mismatch: $crc ne $chk"
}
return "ok"
}
makeFile "<html><head><title>test</title></head><body><p>this is a test</p>\n[string repeat {<p>This is a tcl test file.</p>} 4192]\n</body></html>" testdoc.html
if {![info exists ThreadLevel]} {
if {[catch {package require Thread}] == 0} {
set ValueRange {0 1 2}
} else {
set ValueRange {0 1}
}
# For each value of ThreadLevel, source this file recursively in the
# same interpreter.
foreach ThreadLevel $ValueRange {
source [info script]
}
catch {unset ThreadLevel}
catch {unset ValueRange}
return
}
catch {puts "==== Test with ThreadLevel $ThreadLevel ===="}
http::config -threadlevel $ThreadLevel
# -------------------------------------------------------------------------
test http11-1.0 "normal request for document " -setup {
variable httpd [create_httpd]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html -timeout 10000]
|
| ︙ | ︙ |
Changes to tests/httpPipeline.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
| | > > > > > > > > > > > > > > > > > > > > > > > > | 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 40 41 42 43 44 45 46 47 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
package require http 2.10
# ------------------------------------------------------------------------------
# (0) Socket Creation in Thread, which triples the number of tests.
# ------------------------------------------------------------------------------
if {![info exists ThreadLevel]} {
if {[catch {package require Thread}] == 0} {
set ValueRange {0 1 2}
} else {
set ValueRange {0 1}
}
# For each value of ThreadLevel, source this file recursively in the
# same interpreter.
foreach ThreadLevel $ValueRange {
source [info script]
}
catch {unset ThreadLevel}
catch {unset ValueRange}
return
}
catch {puts "==== Test with ThreadLevel $ThreadLevel ===="}
http::config -threadlevel $ThreadLevel
set sourcedir [file normalize [file dirname [info script]]]
source [file join $sourcedir httpTest.tcl]
source [file join $sourcedir httpTestScript.tcl]
# ------------------------------------------------------------------------------
# (1) Define the test scripts that will be used to generate logs for analysis -
|
| ︙ | ︙ |
Changes to tests/httpd.
| ︙ | ︙ | |||
46 47 48 49 50 51 52 |
proc httpdAccept {newsock ipaddr port} {
global httpd
upvar #0 httpd$newsock data
fconfigure $newsock -blocking 0 -translation {auto crlf}
httpd_log $newsock Connect $ipaddr $port
set data(ipaddr) $ipaddr
| | > > > > | 46 47 48 49 50 51 52 53 54 55 56 57 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 |
proc httpdAccept {newsock ipaddr port} {
global httpd
upvar #0 httpd$newsock data
fconfigure $newsock -blocking 0 -translation {auto crlf}
httpd_log $newsock Connect $ipaddr $port
set data(ipaddr) $ipaddr
fileevent $newsock readable [list httpdRead $newsock]
}
# read data from a client request
proc httpdRead { sock } {
upvar #0 httpd$sock data
if {[eof $sock]} {
set readCount -1
} elseif {![info exists data(state)]} {
# Read the protocol line and parse out the URL and query
set readCount [gets $sock line]
if {[regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/(1.[01])} $line \
-> data(proto) data(url) data(query) data(httpversion)]} {
set data(state) mime
httpd_log $sock Query $line
if {[regexp {(?:^|[\?&])delay=([^&]+)} $data(query) {} val]} {
fileevent $sock readable {}
after $val [list fileevent $sock readable [list httpdRead $sock]]
}
} else {
httpdError $sock 400
httpd_log $sock Error "bad first line:$line"
httpdSockDone $sock
}
return
} elseif {$data(state) == "mime"} {
|
| ︙ | ︙ |
Changes to tests/interp.test.
| ︙ | ︙ | |||
1636 1637 1638 1639 1640 1641 1642 |
} -body {
child hide coroutine
catch {child invokehidden coroutine} m o
dict get $o -errorinfo
} -cleanup {
unset -nocomplain m 0
interp delete child
| | | 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 |
} -body {
child hide coroutine
catch {child invokehidden coroutine} m o
dict get $o -errorinfo
} -cleanup {
unset -nocomplain m 0
interp delete child
} -result {wrong # args: should be "coroutine name cmd ?arg ...?"
while executing
"coroutine"
invoked from within
"child invokehidden coroutine"}
test interp-21.1 {interp hidden} {
interp hidden {}
|
| ︙ | ︙ | |||
2410 2411 2412 2413 2414 2415 2416 |
} {1 {wrong # args: should be "interp recursionlimit path ?newlimit?"}}
test interp-29.1.4 {interp recursionlimit argument checking} {
interp create moo
set result [catch {interp recursionlimit moo bar} msg]
interp delete moo
list $result $msg
} {1 {expected integer but got "bar"}}
| | | | | | | | | | | | 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 |
} {1 {wrong # args: should be "interp recursionlimit path ?newlimit?"}}
test interp-29.1.4 {interp recursionlimit argument checking} {
interp create moo
set result [catch {interp recursionlimit moo bar} msg]
interp delete moo
list $result $msg
} {1 {expected integer but got "bar"}}
test interp-29.1.5 {interp recursionlimit argument checking} -body {
interp create moo
set result [catch {interp recursionlimit moo 0} msg]
interp delete moo
list $result $msg
} -match glob -result {1 {recursion limit must be > 0 and < *}}
test interp-29.1.6 {interp recursionlimit argument checking} -body {
interp create moo
set result [catch {interp recursionlimit moo -1} msg]
interp delete moo
list $result $msg
} -match glob -result {1 {recursion limit must be > 0 and < *}}
test interp-29.1.7 {interp recursionlimit argument checking} {
interp create moo
set result [catch {interp recursionlimit moo [expr {wide(1)<<64}]} msg]
interp delete moo
list $result [string range $msg 0 35]
} {1 {integer value too large to represent}}
test interp-29.1.8 {child recursionlimit argument checking} {
interp create moo
set result [catch {moo recursionlimit foo bar} msg]
interp delete moo
list $result $msg
} {1 {wrong # args: should be "moo recursionlimit ?newlimit?"}}
test interp-29.1.9 {child recursionlimit argument checking} {
interp create moo
set result [catch {moo recursionlimit foo} msg]
interp delete moo
list $result $msg
} {1 {expected integer but got "foo"}}
test interp-29.1.10 {child recursionlimit argument checking} -body {
interp create moo
set result [catch {moo recursionlimit 0} msg]
interp delete moo
list $result $msg
} -match glob -result {1 {recursion limit must be > 0 and < *}}
test interp-29.1.11 {child recursionlimit argument checking} -body {
interp create moo
set result [catch {moo recursionlimit -1} msg]
interp delete moo
list $result $msg
} -match glob -result {1 {recursion limit must be > 0 and < *}}
test interp-29.1.12 {child recursionlimit argument checking} {
interp create moo
set result [catch {moo recursionlimit [expr {wide(1)<<64}]} msg]
interp delete moo
list $result [string range $msg 0 35]
} {1 {integer value too large to represent}}
test interp-29.2.1 {query recursion limit} {
interp recursionlimit {}
} 1000
test interp-29.2.2 {query recursion limit} {
|
| ︙ | ︙ |
Changes to tests/io.test.
| ︙ | ︙ | |||
332 333 334 335 336 337 338 339 340 341 342 343 344 345 |
fconfigure $f -encoding ascii -buffering line -translation lf \
-buffersize 16
puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"]
test io-4.1 {TranslateOutputEOL: lf} {
# search for \n
set f [open $path(test1) w]
fconfigure $f -buffering line -translation lf
puts $f "abcde"
| > > > > > > > > > | 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 |
fconfigure $f -encoding ascii -buffering line -translation lf \
-buffersize 16
puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"]
test io-3.9 {Write: flush line-buffered channels when crlf is split over two buffers} -body {
# https://core.tcl-lang.org/tcllib/tktedit?name=c9d8a52fe
set f [open $path(test1) w]
fconfigure $f -buffering line -translation crlf -buffersize 8
puts $f "1234567"
string map {"\r" "<cr>" "\n" "<lf>"} [contents $path(test1)]
} -cleanup {
close $f
} -result "1234567<cr><lf>"
test io-4.1 {TranslateOutputEOL: lf} {
# search for \n
set f [open $path(test1) w]
fconfigure $f -buffering line -translation lf
puts $f "abcde"
|
| ︙ | ︙ | |||
3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 |
y eval "fileevent $c readable \{readit $c\}"
y eval [list close $c]
update
close $s
interp delete x
interp delete y
} ""
# Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read.
test io-30.1 {Tcl_Write lf, Tcl_Read lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3071 3072 3073 3074 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 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 |
y eval "fileevent $c readable \{readit $c\}"
y eval [list close $c]
update
close $s
interp delete x
interp delete y
} ""
test io-29.36.1 {gets on translation auto with "\r" in QA communication mode, possible regression, bug [b3977d199b]} -constraints {
socket tempNotMac fileevent
} -setup {
set s [open "|[list [interpreter] << {
proc accept {so args} {
fconfigure $so -translation binary
puts -nonewline $so "who are you?\r"; flush $so
set a [gets $so]
puts -nonewline $so "really $a?\r"; flush $so
set a [gets $so]
close $so
set ::done $a
}
set s [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
puts [lindex [fconfigure $s -sockname] 2]
foreach c {1 2} {
vwait ::done
puts $::done
}
}]" r]
set c {}
set result {}
} -body {
set port [gets $s]
foreach t {{cr lf} {auto lf}} {
set c [socket 127.0.0.1 $port]
fconfigure $c -buffering line -translation $t
lappend result $t
while {1} {
set q [gets $c]
switch -- $q {
"who are you?" {puts $c "client"}
"really client?" {puts $c "yes"; lappend result $q; break}
default {puts $c "wrong"; lappend result "unexpected input \"$q\""; break}
}
}
lappend result [gets $s]
close $c; set c {}
}
set result
} -cleanup {
close $s
if {$c ne {}} { close $c }
unset -nocomplain s c port t q
} -result [list {cr lf} "really client?" yes {auto lf} "really client?" yes]
test io-29.36.2 {gets on translation auto with "\r\n" in different buffers, bug [b3977d199b]} -constraints {
socket tempNotMac fileevent
} -setup {
set s [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
set c {}
} -body {
set ::cnt 0
proc accept {so args} {
fconfigure $so -translation binary
puts -nonewline $so "1 line\r"
puts -nonewline $so "\n2 li"
flush $so
# now force separate packets
puts -nonewline $so "ne\r"
flush $so
if {$::cnt & 1} {
vwait ::cli; # simulate short delay (so client can process events, just wait for it)
} else {
# we don't have a delay, so client would get the lines as single chunk
}
# we'll try with "\r" and without "\r" (to cover both branches, where "\r" and "eof" causes exit from [gets] by 3rd line)
puts -nonewline $so "\n3 line"
if {!($::cnt % 3)} {
puts -nonewline $so "\r"
}
flush $so
close $so
}
while {$::cnt < 6} { incr ::cnt
set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
fconfigure $c -blocking 0 -buffering line -translation auto
fileevent $c readable [list apply {c {
if {[gets $c line] >= 0} {
lappend ::cli <$line>
} elseif {[eof $c]} {
set ::done 1
}
}} $c]
vwait ::done
close $c; set c {}
}
set ::cli
} -cleanup {
close $s
if {$c ne {}} { close $c }
unset -nocomplain ::done ::cli ::cnt s c
} -result [lrepeat 6 {<1 line>} {<2 line>} {<3 line>}]
# Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read.
test io-30.1 {Tcl_Write lf, Tcl_Read lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
|
| ︙ | ︙ | |||
5859 5860 5861 5862 5863 5864 5865 |
} -result 1
test io-40.17 {tilde substitution in open} {
set home $::env(HOME)
unset ::env(HOME)
set x [list [catch {open ~/foo} msg] $msg]
set ::env(HOME) $home
set x
| | | 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 |
} -result 1
test io-40.17 {tilde substitution in open} {
set home $::env(HOME)
unset ::env(HOME)
set x [list [catch {open ~/foo} msg] $msg]
set ::env(HOME) $home
set x
} {1 {couldn't open "~/foo": no such file or directory}}
test io-41.1 {Tcl_FileeventCmd: errors} {fileevent} {
list [catch {fileevent foo} msg] $msg
} {1 {wrong # args: should be "fileevent channelId event ?script?"}}
test io-41.2 {Tcl_FileeventCmd: errors} {fileevent} {
list [catch {fileevent foo bar baz q} msg] $msg
} {1 {wrong # args: should be "fileevent channelId event ?script?"}}
|
| ︙ | ︙ | |||
8460 8461 8462 8463 8464 8465 8466 |
test io-60.1 {writing illegal utf sequences} {fileevent testbytestring} {
# This test will hang in older revisions of the core.
set out [open $path(script) w]
puts $out "catch {load $::tcltestlib Tcltest}"
puts $out {
| | | 8562 8563 8564 8565 8566 8567 8568 8569 8570 8571 8572 8573 8574 8575 8576 |
test io-60.1 {writing illegal utf sequences} {fileevent testbytestring} {
# This test will hang in older revisions of the core.
set out [open $path(script) w]
puts $out "catch {load $::tcltestlib Tcltest}"
puts $out {
puts ABC[testbytestring \xE2]
exit 1
}
proc readit {pipe} {
variable x
variable result
if {[eof $pipe]} {
set x [catch {close $pipe} line]
|
| ︙ | ︙ | |||
8484 8485 8486 8487 8488 8489 8490 |
variable x ""
set result ""
vwait [namespace which -variable x]
# cut of the remainder of the error stack, especially the filename
set result [lreplace $result 3 3 [lindex [split [lindex $result 3] \n] 0]]
list $x $result
| | | 8586 8587 8588 8589 8590 8591 8592 8593 8594 8595 8596 8597 8598 8599 8600 |
variable x ""
set result ""
vwait [namespace which -variable x]
# cut of the remainder of the error stack, especially the filename
set result [lreplace $result 3 3 [lindex [split [lindex $result 3] \n] 0]]
list $x $result
} {1 {gets ABC catch {error writing "stdout": illegal byte sequence}}}
test io-61.1 {Reset eof state after changing the eof char} -setup {
set datafile [makeFile {} eofchar]
set f [open $datafile w]
fconfigure $f -translation binary
puts -nonewline $f [string repeat "Ho hum\n" 11]
puts $f =
|
| ︙ | ︙ | |||
8845 8846 8847 8848 8849 8850 8851 8852 8853 8854 8855 8856 8857 8858 8859 8860 8861 8862 8863 |
catch {read [teststringobj get 1]}
read [teststringobj get 2]
} -cleanup {
interp delete child
testobj freeallvars
removeFile io-74.1
} -returnCodes error -match glob -result {can not find channel named "*"}
# ### ### ### ######### ######### #########
# cleanup
foreach file [list fooBar longfile script script2 output test1 pipe my_script \
test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] {
removeFile $file
}
cleanupTests
}
namespace delete ::tcl::test::io
return
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 8947 8948 8949 8950 8951 8952 8953 8954 8955 8956 8957 8958 8959 8960 8961 8962 8963 8964 8965 8966 8967 8968 8969 8970 8971 8972 8973 8974 8975 8976 8977 8978 8979 8980 8981 8982 8983 8984 8985 8986 8987 8988 8989 8990 8991 8992 8993 8994 8995 8996 8997 8998 8999 9000 9001 9002 9003 9004 9005 9006 9007 9008 9009 9010 9011 9012 9013 9014 9015 9016 9017 9018 9019 9020 9021 9022 9023 9024 9025 9026 9027 9028 9029 9030 9031 9032 9033 9034 9035 9036 9037 9038 9039 9040 9041 9042 9043 9044 9045 9046 9047 9048 9049 9050 9051 9052 9053 9054 9055 9056 9057 9058 9059 9060 9061 9062 9063 9064 9065 9066 9067 9068 |
catch {read [teststringobj get 1]}
read [teststringobj get 2]
} -cleanup {
interp delete child
testobj freeallvars
removeFile io-74.1
} -returnCodes error -match glob -result {can not find channel named "*"}
# The following tests 75.1 to 75.5 exercise strict or tolerant channel
# encoding.
# They are left as a place-holder here. If TIP633 is voted, they will
# come back.
# Exercise strct channel encoding
test io-75.6 {multibyte encoding error read results in raw bytes} -setup {
set fn [makeFile {} io-75.6]
set f [open $fn w+]
fconfigure $f -encoding binary
# In UTF-8, a byte 0xCx starts a multibyte sequence and must be followed
# by a byte > 0x7F. This is violated to get an invalid sequence.
puts -nonewline $f "A\xC0\x40"
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none
} -constraints knownBug -body {
set d [read $f]
binary scan $d H* hd
set hd
} -cleanup {
close $f
removeFile io-75.6
} -result "41"
# The current result cuts at the invalid sequence. IMHO, there should be an
# error thrown or the whole sequence should be returned as byte (compat mode).
test io-75.7 {unrepresentable character write passes and is replaced by ?} -setup {
set fn [makeFile {} io-75.7]
set f [open $fn w+]
fconfigure $f -encoding iso8859-1
} -body {
catch {puts -nonewline $f "A\u2022"} msg
flush $f
seek $f 0
list [read $f] $msg
} -cleanup {
close $f
removeFile io-75.7
} -match glob -result [list {A} {error writing "*": illegal byte sequence}]
# Incomplete sequence test.
# This error may IMHO only be detected with the close.
# But the read already returns the incomplete sequence.
test io-75.8 {incomplete multibyte encoding read is ignored} -setup {
set fn [makeFile {} io-75.8]
set f [open $fn w+]
fconfigure $f -encoding binary
puts -nonewline $f "A\xC0"
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none
} -body {
set d [read $f]
close $f
binary scan $d H* hd
set hd
} -cleanup {
removeFile io-75.8
} -result "41c0"
# The current result returns the orphan byte as byte.
# This may be expected due to special utf-8 handling.
# As utf-8 has a special treatment in multi-byte decoding, also test another
# one.
test io-75.9 {shiftjis encoding error read results in raw bytes} -setup {
set fn [makeFile {} io-75.9]
set f [open $fn w+]
fconfigure $f -encoding binary
# In shiftjis, \x81 starts a two-byte sequence.
# But 2nd byte \xFF is not allowed
puts -nonewline $f "A\x81\xFFA"
flush $f
seek $f 0
fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf
} -constraints knownBug -body {
set d [read $f]
binary scan $d H* hd
set hd
} -cleanup {
close $f
removeFile io-75.9
} -result "41"
# The current result cuts at the invalid sequence. IMHO, there should be an
# error thrown or the whole sequence should be returned as byte (compat mode).
test io-75.10 {incomplete shiftjis encoding read is ignored} -setup {
set fn [makeFile {} io-75.10]
set f [open $fn w+]
fconfigure $f -encoding binary
# \x81 announces a two byte sequence.
puts -nonewline $f "A\x81"
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf
} -body {
set d [read $f]
close $f
binary scan $d H* hd
set hd
} -cleanup {
removeFile io-75.10
} -result "4181"
# ### ### ### ######### ######### #########
# cleanup
foreach file [list fooBar longfile script script2 output test1 pipe my_script \
test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] {
removeFile $file
}
cleanupTests
}
namespace delete ::tcl::test::io
return
|
Changes to tests/listObj.test.
| ︙ | ︙ | |||
191 192 193 194 195 196 197 198 199 200 201 202 203 204 |
[testlistobj get 1]
}
-cleanup {
testobj freeallvars
}
-result {{a b c d e} {} {a b c d e f}}
}
test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj {
testobj bug3598580
} 123
# cleanup
::tcltest::cleanupTests
| > > > > > > > > > > > > > > > > > > > > | 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 219 220 221 222 223 224 |
[testlistobj get 1]
}
-cleanup {
testobj freeallvars
}
-result {{a b c d e} {} {a b c d e f}}
}
test listobj-10.2 {Tcl_ListObjReplace with negative start value} testobj {
testlistobj set 1 a b c d e
testlistobj replace 1 -1 2 f
testlistobj get 1
} {f c d e}
test listobj-10.3 {Tcl_ListObjReplace with negative count value} testobj {
testlistobj set 1 a b c d e
testlistobj replace 1 1 -1 f
testlistobj get 1
} {a f b c d e}
test listobj-10.4 {Tcl_ListObjReplace with UINT_MAX-1 count value} testobj {
testlistobj set 1 a b c d e
testlistobj replace 1 1 0xFFFFFFFE f
testlistobj get 1
} {a f}
test listobj-10.5 {Tcl_ListObjReplace with SIZE_MAX-1 count value} testobj {
testlistobj set 1 a b c d e
testlistobj replace 1 1 -2 f
testlistobj get 1
} {a f}
test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj {
testobj bug3598580
} 123
# cleanup
::tcltest::cleanupTests
|
| ︙ | ︙ |
Added tests/listRep.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 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 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 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 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 219 220 221 222 223 224 225 226 227 228 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 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 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 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 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 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 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 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 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 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 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 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 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 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 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 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 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 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 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 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 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 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 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 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 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 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 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 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 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 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 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 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 2537 2538 |
# This file contains tests that specifically exercise the internal representation
# of a list.
#
# Copyright © 2022 Ashok P. Nadkarni
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Unlike the other files related to list commands which for the most part do
# black box testing focusing on functionality, this file does more of white box
# testing to exercise code paths that implement different list representations
# (with spans, leading free space etc., shared/unshared etc.) In addition to
# functional correctness, the tests also check for the expected internal
# representation as that pertains to performance heuristics. Generally speaking,
# combinations of the following need to be tested,
# - free space in front, back, neither, both of list representation
# - shared Tcl_Objs
# - shared internal reps (independent of shared Tcl_Objs)
# - byte-compiled vs non-compiled
#
# Being white box tests, they are sensitive to changes to further optimizations
# and changes in heuristics. That cannot be helped.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testlistrep [llength [info commands testlistrep]]
proc describe {l args} {dict get [testlistrep describe $l] {*}$args}
proc irange {first last} {
set l {}
while {$first <= $last} {
lappend l $first
incr first
}
return $l
}
proc leadSpace {l} {
# Returns the leading space in a list store
return [dict get [describe $l] store firstUsed]
}
proc tailSpace {l} {
# Returns the trailing space in a list store
array set rep [describe $l]
dict with rep(store) {
return [expr {$numAllocated - ($firstUsed + $numUsed)}]
}
}
proc allocated {l} {
# Returns the allocated space in a list store
return [dict get [describe $l] store numAllocated]
}
proc repStoreRefCount {l} {
# Returns the ref count for the list store
return [dict get [describe $l] store refCount]
}
proc validate {l} {
# Panics if internal listrep structures are not valid
testlistrep validate $l
}
proc leadSpaceMore {l} {
set leadSpace [leadSpace $l]
expr {$leadSpace > 0 && $leadSpace >= 2*[tailSpace $l]}
}
proc tailSpaceMore {l} {
set tailSpace [tailSpace $l]
expr {$tailSpace > 0 && $tailSpace >= 2*[leadSpace $l]}
}
proc spaceEqual {l} {
# 1 if lead and tail space shared (diff of 1 at most) and more than 0
set leadSpace [leadSpace $l]
set tailSpace [tailSpace $l]
if {$leadSpace == 0 && $tailSpace == 0} {
# At least one must be positive
return 0
}
set diff [expr {$leadSpace - $tailSpace}]
return [expr {$diff >= -1 && $diff <= 1}]
}
proc storeAddress {l} {
return [describe $l store memoryAddress]
}
proc sameStore {l1 l2} {
expr {[storeAddress $l1] == [storeAddress $l2]}
}
proc hasSpan {l args} {
# Returns 1 if list has a span. If args are specified, they are checked with
# span values (start and length)
array set rep [describe $l]
if {![info exists rep(span)]} {
return 0
}
if {[llength $args] == 0} {
return 1; # No need to check values
}
lassign $args start len
if {[dict get $rep(span) spanStart] == $start &&
[dict get $rep(span) spanLength] == $len} {
return 1
}
return 0
}
proc checkListrep {l listLen numAllocated leadSpace tailSpace {refCount 0}} {
# Checks if the internal representation of $l match
# passed arguments. Return "" if yes, else error messages.
array set rep [testlistrep describe $l]
set rep(leadSpace) [dict get $rep(store) firstUsed]
set rep(numAllocated) [dict get $rep(store) numAllocated]
set rep(tailSpace) [expr {
$rep(numAllocated) - ($rep(leadSpace) + [dict get $rep(store) numUsed])
}]
set rep(refCount) [dict get $rep(store) refCount]
if {[info exists rep(span)]} {
set rep(listLen) [dict get $rep(span) spanLength]
} else {
set rep(listLen) [dict get $rep(store) numUsed]
}
set errors [list]
foreach arg {listLen numAllocated leadSpace tailSpace} {
if {$rep($arg) != [set $arg]} {
lappend errors "$arg in list representation ($rep($arg)) is not expected value ([set $arg])."
}
}
# Check refCount only if caller has specified it as non-0
if {$refCount && $refCount != $rep(refCount)} {
lappend errors "refCount in list representation ($rep(refCount)) is not expected value ($refCount)."
}
return $errors
}
proc assertListrep {l listLen numAllocated leadSpace tailSpace {refCount 0}} {
# Like check_listrep but raises error
set errors [checkListrep $l $listLen $numAllocated $leadSpace $tailSpace $refCount]
if {[llength $errors]} {
error [join $errors \n]
}
return
}
# The default length should be large enough that doubling the allocation will
# clearly distinguish free space allocation difference between front and back.
# (difference in the two should at least be 2 else we cannot tell if front
# or back was favored appropriately)
proc freeSpaceNone {{len 8}} {return [testlistrep new $len 0 0]}
proc freeSpaceLead {{len 8} {lead 3}} {return [testlistrep new $len $lead 0]}
proc freeSpaceTail {{len 8} {tail 3}} {return [testlistrep new $len 0 $tail]}
proc freeSpaceBoth {{len 8} {lead 3} {tail 3}} {
return [testlistrep new $len $lead $tail]
}
proc zombieSample {{len 1000} {leadzombies 100} {tailzombies 100}} {
# returns an unshared listrep with zombies in front and back
# don't combine freespacenone and lrange else zombies are freed
set l [freeSpaceNone [expr {$len+$leadzombies+$tailzombies}]]
return [lrange $l $leadzombies [expr {$leadzombies+$len-1}]]
}
# Just ensure above stubs return what's expected
if {[testConstraint testlistrep]} {
assertListrep [freeSpaceNone] 8 8 0 0 1
assertListrep [freeSpaceLead] 8 11 3 0 1
assertListrep [freeSpaceTail] 8 11 0 3 1
assertListrep [freeSpaceBoth] 8 14 3 3 1
assertListrep [zombieSample] 1000 1200 0 0 1
if {![hasSpan [zombieSample]] || [dict get [testlistrep describe [zombieSample]] span spanStart] == 0} {
error "zombieSample span missing or span start is at 0."
}
}
# Define some variables for some indices because the Tcl compiler will do some
# operations completely in byte code if indices are literals
set zero 0
set one 1
set two 2
set four 4
set end end
#
# Test sets:
# 1.* - unshared internal rep, no spans, with no free space
# 2.* - shared internal rep, no spans, with no free space
# 3.* - unshared internal rep, spanned
# 4.* - shared internal rep, spanned
# 5.* - shared Tcl_Obj
# 6.* - lists with zombie Tcl_Obj's
#
# listrep-1.* tests all operate on unshared listreps with no free space
test listrep-1.1 {
Inserts in front of unshared list with no free space should reallocate with
equal free space at front and back -- linsert version
} -constraints testlistrep -body {
set l [linsert [freeSpaceNone] $zero 99]
validate $l
list $l [spaceEqual $l]
} -result [list {99 0 1 2 3 4 5 6 7} 1]
test listrep-1.1.1 {
Inserts in front of unshared list with no free space should reallocate with
equal free space at front and back -- lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceNone] $zero -1 99]
validate $l
list $l [spaceEqual $l]
} -result [list {99 0 1 2 3 4 5 6 7} 1]
test listrep-1.2 {
Inserts at back of unshared list with no free space should allocate all
space at back -- linsert version
} -constraints testlistrep -body {
set l [linsert [freeSpaceNone] $end 99]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 1 2 3 4 5 6 7 99} 0 9]
test listrep-1.2.1 {
Inserts at back of unshared list with no free space should allocate all
space at back -- lset version
} -constraints testlistrep -body {
set l [freeSpaceNone]
lset l $end+1 99
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 1 2 3 4 5 6 7 99} 0 9]
test listrep-1.2.2 {
Inserts at back of unshared list with no free space should allocate all
space at back -- lappend version
} -constraints testlistrep -body {
set l [freeSpaceNone]
lappend l 99
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 1 2 3 4 5 6 7 99} 0 9]
test listrep-1.3 {
Inserts in middle of unshared list with no free space should reallocate with
equal free space at front and back - linsert version
} -constraints testlistrep -body {
set l [linsert [freeSpaceNone] $four 99]
validate $l
list $l [spaceEqual $l]
} -result [list {0 1 2 3 99 4 5 6 7} 1]
test listrep-1.3.1 {
Inserts in middle of unshared list with no free space should reallocate with
equal free space at front and back - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceNone] $four $four-1 99]
validate $l
list $l [spaceEqual $l]
} -result [list {0 1 2 3 99 4 5 6 7} 1]
test listrep-1.4 {
Deletes from front of small unshared list with no free space should
just shift up leaving room at back - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceNone] $zero $zero]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {1 2 3 4 5 6 7} 0 1]
test listrep-1.4.1 {
Deletes from front of small unshared list with no free space should
just shift up leaving room at back - lassign version
} -constraints testlistrep -body {
set l [lassign [freeSpaceNone] e]
validate $l
list $e $l [leadSpace $l] [tailSpace $l]
} -result [list 0 {1 2 3 4 5 6 7} 0 1]
test listrep-1.4.2 {
Deletes from front of small unshared list with no free space should
just shift up leaving room at back - lpop version
} -constraints testlistrep -body {
set l [freeSpaceNone]
set e [lpop l $zero]
validate $l
list $e $l [leadSpace $l] [tailSpace $l]
} -result [list 0 {1 2 3 4 5 6 7} 0 1]
test listrep-1.4.3 {
Deletes from front of small unshared list with no free space should
just shift up leaving room at back - lrange version
} -constraints testlistrep -body {
set l [lrange [freeSpaceNone] $one $end]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {1 2 3 4 5 6 7} 0 1]
test listrep-1.4.4 {
Deletes from front of small unshared list with no free space should
just shift up leaving room at back - lremove version
} -constraints testlistrep -body {
set l [lremove [freeSpaceNone] $zero]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {1 2 3 4 5 6 7} 0 1]
test listrep-1.5 {
Deletes from front of large unshared list with no free space should
create a span - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceNone 1000] $zero $one]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 2 998]
} -result [list [irange 2 999] 2 0 1]
test listrep-1.5.1 {
Deletes from front of large unshared list with no free space should
create a span - lassign version
} -constraints testlistrep -body {
set l [lassign [freeSpaceNone 1000] e]
validate $l
list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l 1 999]
} -result [list 0 [irange 1 999] 1 0 1]
test listrep-1.5.2 {
Deletes from front of large unshared list with no free space should
create a span - lrange version
} -constraints testlistrep -body {
set l [lrange [freeSpaceNone 1000] $two end]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 2 998]
} -result [list [irange 2 999] 2 0 1]
test listrep-1.5.3 {
Deletes from front of large unshared list with no free space should
create a span - lremove version
} -constraints testlistrep -body {
set l [lremove [freeSpaceNone 1000] $zero]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 1 999]
} -result [list [irange 1 999] 1 0 1]
test listrep-1.5.4 {
Deletes from front of large unshared list with no free space should
create a span - lpop version
} -constraints testlistrep -body {
set l [freeSpaceNone 1000]
set e [lpop l 0]
validate $l
list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l 1 999]
} -result [list 0 [irange 1 999] 1 0 1]
test listrep-1.6 {
Deletes closer to front of large list should move (smaller) front segment
-- lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceNone 1000] $four $four]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 1 999]
} -result [list [concat [irange 0 3] [irange 5 999]] 1 0 1]
test listrep-1.6.1 {
Deletes closer to front of large list should move (smaller) front segment
-- lpop version
} -constraints testlistrep -body {
set l [freeSpaceNone 1000]
set e [lpop l $four]
validate $l
list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l 1 999]
} -result [list 4 [concat [irange 0 3] [irange 5 999]] 1 0 1]
test listrep-1.7 {
Deletes closer to back of large list should move (smaller) back segment
and will not need a span - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceNone 1000] end-$four end-$four]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l]
} -result [list [concat [irange 0 994] [irange 996 999]] 0 1 0]
test listrep-1.7.1 {
Deletes closer to back of large list should move (smaller) back segment
and will not need a span - lpop version
} -constraints testlistrep -body {
set l [freeSpaceNone 1000]
set e [lpop l $end-4]
validate $l
list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l]
} -result [list 995 [concat [irange 0 994] [irange 996 999]] 0 1 0]
test listrep-1.8 {
Deletes at back of small unshared list should not need a span - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceNone] end-$one end]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l]
} -result [list {0 1 2 3 4 5} 0 2 0]
test listrep-1.8.1 {
Deletes at back of small unshared list should not need a span - lrange version
} -constraints testlistrep -body {
set l [lrange [freeSpaceNone] $zero end-$two]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l]
} -result [list {0 1 2 3 4 5} 0 2 0]
test listrep-1.8.2 {
Deletes at back of small unshared list should not need a span - lremove version
} -constraints testlistrep -body {
set l [lremove [freeSpaceNone] $end-1 $end]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l]
} -result [list {0 1 2 3 4 5} 0 2 0]
test listrep-1.8.3 {
Deletes at back of small unshared list should not need a span - lpop version
} -constraints testlistrep -body {
set l [freeSpaceNone]
set e [lpop l $end]
validate $l
list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l]
} -result [list 7 {0 1 2 3 4 5 6} 0 1 0]
test listrep-1.9 {
Deletes at back of large unshared list should not need a span - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceNone 1000] end-$four end]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l]
} -result [list [irange 0 994] 0 5 0]
test listrep-1.9.1 {
Deletes at back of large unshared list should not need a span - lrange version
} -constraints testlistrep -body {
set l [lrange [freeSpaceNone 1000] 0 $end-5]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l]
} -result [list [irange 0 994] 0 5 0]
test listrep-1.9.2 {
Deletes at back of large unshared list should not need a span - lremove version
} -constraints testlistrep -body {
set l [lremove [freeSpaceNone 1000] end-$four $end-3 end-$two $end-1 $end]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l]
} -result [list [irange 0 994] 0 5 0]
test listrep-1.9.3 {
Deletes at back of large unshared list should not need a span - lpop version
} -constraints testlistrep -body {
set l [freeSpaceNone 1000]
set e [lpop l $end]
validate $l
list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l]
} -result [list 999 [irange 0 998] 0 1 0]
test listrep-1.10 {
no-op on unshared list should force a canonical list string - lreplace version
} -body {
lreplace { 1 2 3 4 } $zero -1
} -result {1 2 3 4}
test listrep-1.10.1 {
no-op on unshared list should force a canonical list string - lrange version
} -body {
lrange { 1 2 3 4 } $zero $end
} -result {1 2 3 4}
test listrep-1.11 {
Append elements to large unshared list is optimized as lappend
so no free space in front - lreplace version
} -body {
# Note $end, not end else byte code compiler short-cuts
set l [lreplace [freeSpaceNone 1000] $end+1 $end+1 1000]
validate $l
list $l [leadSpace $l] [expr {[tailSpace $l] > 0}] [hasSpan $l]
} -result [list [irange 0 1000] 0 1 0]
test listrep-1.11.1 {
Append elements to large unshared list is optimized as lappend
so no free space in front - linsert version
} -body {
# Note $end, not end else byte code compiler short-cuts
set l [linsert [freeSpaceNone 1000] $end+1 1000]
validate $l
list $l [leadSpace $l] [expr {[tailSpace $l] > 0}] [hasSpan $l]
} -result [list [irange 0 1000] 0 1 0]
test listrep-1.11.2 {
Append elements to large unshared list leaves no free space in front
- lappend version
} -body {
# Note $end, not end else byte code compiler short-cuts
set l [freeSpaceNone 1000]
lappend l 1000 1001
validate $l
list $l [leadSpace $l] [expr {[tailSpace $l] > 0}] [hasSpan $l]
} -result [list [irange 0 1001] 0 1 0]
test listrep-1.12 {
Replacement of elements at front with same number elements in unshared list
is in-place - lreplace version
} -body {
set l [lreplace [freeSpaceNone] $zero $one 10 11]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {10 11 2 3 4 5 6 7} 0 0]
test listrep-1.12.1 {
Replacement of elements at front with same number elements in unshared list
is in-place - lset version
} -body {
set l [freeSpaceNone]
lset l 0 -1
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {-1 1 2 3 4 5 6 7} 0 0]
test listrep-1.13 {
Replacement of elements at front with fewer elements in unshared list
results in a spanned list with space only in front
} -body {
set l [lreplace [freeSpaceNone] $zero $four 10]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {10 5 6 7} 4 0]
test listrep-1.14 {
Replacement of elements at front with more elements in unshared list
results in a reallocated spanned list with space at front and back
} -body {
set l [lreplace [freeSpaceNone] $zero $one 10 11 12]
validate $l
list $l [spaceEqual $l]
} -result [list {10 11 12 2 3 4 5 6 7} 1]
test listrep-1.15 {
Replacement of elements in middle with same number elements in unshared list
is in-place - lreplace version
} -body {
set l [lreplace [freeSpaceNone] $one $two 10 11]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 10 11 3 4 5 6 7} 0 0]
test listrep-1.15.1 {
Replacement of elements in middle with same number elements in unshared list
is in-place - lset version
} -body {
set l [freeSpaceNone]
lset l $two -1
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 1 -1 3 4 5 6 7} 0 0]
test listrep-1.16 {
Replacement of elements in front half with fewer elements in unshared list
results in a spanned list with space only in front since smaller segment moved
} -body {
set l [lreplace [freeSpaceNone] $one $four 10]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 10 5 6 7} 3 0]
test listrep-1.17 {
Replacement of elements in back half with fewer elements in unshared list
results in a spanned list with space only at back
} -body {
set l [lreplace [freeSpaceNone] end-$four end-$one 10]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 1 2 10 7} 0 3]
test listrep-1.18 {
Replacement of elements in middle more elements in unshared list
results in a reallocated spanned list with space at front and back
} -body {
set l [lreplace [freeSpaceNone] $one $two 10 11 12]
validate $l
list $l [spaceEqual $l]
} -result [list {0 10 11 12 3 4 5 6 7} 1]
test listrep-1.19 {
Replacement of elements at back with same number elements in unshared list
is in-place - lreplace version
} -body {
set l [lreplace [freeSpaceNone] $end-1 $end 10 11]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 1 2 3 4 5 10 11} 0 0]
test listrep-1.19.1 {
Replacement of elements at back with same number elements in unshared list
is in-place - lset version
} -body {
set l [freeSpaceNone]
lset l $end 10
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 1 2 3 4 5 6 10} 0 0]
test listrep-1.20 {
Replacement of elements at back with fewer elements in unshared list
is in-place with space only at the back
} -body {
set l [lreplace [freeSpaceNone] $end-2 $end 10]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 1 2 3 4 10} 0 2]
test listrep-1.21 {
Replacement of elements at back with more elements in unshared list
allocates new representation with equal space at front and back
} -body {
set l [lreplace [freeSpaceNone] $end-1 $end 10 11 12]
validate $l
list $l [spaceEqual $l]
} -result [list {0 1 2 3 4 5 10 11 12} 1]
#
# listrep-2.* tests all operate on shared list reps with no free space. Note the
# *list internal rep* must be shared, not only the Tcl_Obj so just assigning to
# another variable does not suffice. The lrange construct on an variable's value
# will do the needful.
test listrep-2.1 {
Inserts in front of shared list with no free space should reallocate with
more leading space in front - linsert version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [linsert $b $zero 99]
validate $l
list [repStoreRefCount $b] $l [leadSpaceMore $l] [repStoreRefCount $l]
} -result [list 2 {99 0 1 2 3 4 5 6 7} 1 1]
test listrep-2.1.1 {
Inserts in front of shared list with no free space should reallocate with
more leading space in front - lreplace version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lreplace $b $zero -1 99]
validate $l
list [repStoreRefCount $b] $l [leadSpaceMore $l] [repStoreRefCount $l]
} -result [list 2 {99 0 1 2 3 4 5 6 7} 1 1]
test listrep-2.2 {
Inserts at back of shared list with no free space should reallocate with
more leading space in back - linsert version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [linsert $b $end 99]
validate $l
list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l]
} -result [list 2 {0 1 2 3 4 5 6 7 99} 1 1]
test listrep-2.2.1 {
Inserts at back of shared list with no free space should reallocate with
more leading space in back - lreplace version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lreplace $b $end+1 end+$one 99]
validate $l
list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l]
} -result [list 2 {0 1 2 3 4 5 6 7 99} 1 1]
test listrep-2.2.2 {
Inserts at back of shared list with no free space should reallocate with
more leading space in back - lappend version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lappend b 99]
validate $l
list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l]
} -result [list 1 {0 1 2 3 4 5 6 7 99} 1 1]
test listrep-2.2.3 {
Inserts at back of shared list with no free space should reallocate with
more leading space in back - lset version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lset b $end+1 99]
validate $l
list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l]
} -result [list 1 {0 1 2 3 4 5 6 7 99} 1 1]
test listrep-2.3 {
Inserts in middle of shared list with no free space should reallocate with
equal spacing - linsert version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [linsert $b $four 99]
validate $l
list [repStoreRefCount $b] $l [spaceEqual $l] [repStoreRefCount $l]
} -result [list 2 {0 1 2 3 99 4 5 6 7} 1 1]
test listrep-2.3.1 {
Inserts in middle of shared list with no free space should reallocate with
equal spacing - lreplace version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lreplace $b $four $four-1 99]
validate $l
list [repStoreRefCount $b] $l [spaceEqual $l] [repStoreRefCount $l]
} -result [list 2 {0 1 2 3 99 4 5 6 7} 1 1]
test listrep-2.4 {
Deletes from front of small shared list with no free space should
allocate new list of exact size - lreplace version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lreplace $b $zero $zero]
validate $l
list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list 2 {1 2 3 4 5 6 7} 0 0 1]
test listrep-2.4.1 {
Deletes from front of small shared list with no free space should
allocate new list of exact size - lremove version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lremove $b $zero $one]
validate $l
list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list 2 {2 3 4 5 6 7} 0 0 1]
test listrep-2.4.2 {
Deletes from front of small shared list with no free space should
allocate new list of exact size - lrange version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lrange $b $one $end]
validate $l
list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list 2 {1 2 3 4 5 6 7} 0 0 1]
test listrep-2.4.3 {
Deletes from front of small shared list with no free space should
allocate new list of exact size - lassign version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lassign $b e]
validate $l
list $e [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list 0 2 {1 2 3 4 5 6 7} 0 0 1]
test listrep-2.4.4 {
Deletes from front of small shared list with no free space should
allocate new list of exact size - lpop version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set l [lrange $a $zero end]; # Ensure shared listrep
set e [lpop l $zero]
validate $l
list $e $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list 0 {1 2 3 4 5 6 7} 0 0 1]
test listrep-2.5 {
Deletes from front of large shared list with no free space should
create span - lreplace version
} -constraints testlistrep -body {
set a [freeSpaceNone 1000]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lreplace $b $zero $zero]
validate $l
# The listrep store should be shared among a, b, l (3 refs)
list [sameStore $b $l] [repStoreRefCount $b] $l [hasSpan $l] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list 1 3 [irange 1 999] 1 0 0 3]
test listrep-2.5.1 {
Deletes from front of large shared list with no free space should
create span - lremove version
} -constraints testlistrep -body {
set a [freeSpaceNone 1000]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lremove $b $zero $one]
validate $l
# The listrep store should be shared among a, b, l (3 refs)
list [sameStore $b $l] [repStoreRefCount $b] $l [hasSpan $l] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list 1 3 [irange 2 999] 1 0 0 3]
test listrep-2.5.2 {
Deletes from front of large shared list with no free space should
create span - lrange version
} -constraints testlistrep -body {
set a [freeSpaceNone 1000]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lrange $b $two $end]
validate $l
# The listrep store should be shared among a, b, l (3 refs)
list [sameStore $b $l] [repStoreRefCount $b] $l [hasSpan $l] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list 1 3 [irange 2 999] 1 0 0 3]
test listrep-2.5.3 {
Deletes from front of large shared list with no free space should
create span - lassign version
} -constraints testlistrep -body {
set a [freeSpaceNone 1000]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lassign $b e]
validate $l
# The listrep store should be shared among a, b, l (3 refs)
list $e [sameStore $b $l] [repStoreRefCount $b] $l [hasSpan $l] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list 0 1 3 [irange 1 999] 1 0 0 3]
test listrep-2.5.4 {
Deletes from front of large shared list with no free space should
create span - lpop version
} -constraints testlistrep -body {
set a [freeSpaceNone 1000]
set l [lrange $a $zero end]; # Ensure shared listrep
set e [lpop l $zero]
validate $l
# The listrep store should be shared among a, b, l (3 refs)
list $e $l [hasSpan $l] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list 0 [irange 1 999] 1 0 0 2]
test listrep-2.6 {
Deletes from back of small shared list with no free space should
allocate new list of exact size - lreplace version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lreplace $b $end $end]
validate $l
list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list 2 {0 1 2 3 4 5 6} 0 0 1]
test listrep-2.6.1 {
Deletes from back of small shared list with no free space should
allocate new list of exact size - lremove version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lremove $b $end $end-1]
validate $l
list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list 2 {0 1 2 3 4 5} 0 0 1]
test listrep-2.6.2 {
Deletes from back of small shared list with no free space should
allocate new list of exact size - lrange version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lrange $b $zero $end-1]
validate $l
list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list 2 {0 1 2 3 4 5 6} 0 0 1]
test listrep-2.6.3 {
Deletes from back of small shared list with no free space should
allocate new list of exact size - lpop version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set l [lrange $a $zero end]; # Ensure shared listrep
set e [lpop l]
validate $l
list $e $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list 7 {0 1 2 3 4 5 6} 0 0 1]
test listrep-2.7 {
Deletes from back of large shared list with no free space should
use a span - lreplace version
} -constraints testlistrep -body {
set a [freeSpaceNone 1000]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lreplace $b $end $end]
validate $l
# Note lead and tail space is 0 because original list store in a,b is used
list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list 3 [irange 0 998] 0 0 3]
test listrep-2.7.1 {
Deletes from back of large shared list with no free space should
use a span - lremove version
} -constraints testlistrep -body {
set a [freeSpaceNone 1000]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lremove $b $end-1 $end]
validate $l
# Note lead and tail space is 0 because original list store in a,b is used
list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list 3 [irange 0 997] 0 0 3]
test listrep-2.7.2 {
Deletes from back of large shared list with no free space should
use a span - lrange version
} -constraints testlistrep -body {
set a [freeSpaceNone 1000]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lrange $b $zero $end-1]
validate $l
# Note lead and tail space is 0 because original list store in a,b is used
list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list 3 [irange 0 998] 0 0 3]
test listrep-2.7.3 {
Deletes from back of large shared list with no free space should
use a span - lpop version
} -constraints testlistrep -body {
set a [freeSpaceNone 1000]
set l [lrange $a $zero end]; # Ensure shared listrep
set e [lpop l]
validate $l
# Note lead and tail space is 0 because original list store in a,b is used
list $e $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list 999 [irange 0 998] 0 0 2]
test listrep-2.8 {
no-op on shared list should force a canonical list representation
with original unchanged - lreplace version
} -body {
set l { 1 2 3 4 }
list [lreplace $l $zero -1] $l
} -result [list {1 2 3 4} { 1 2 3 4 }]
test listrep-2.8.1 {
no-op on shared list should force a canonical list representation
with original unchanged - lrange version
} -body {
set l { 1 2 3 4 }
list [lrange $l $zero end] $l
} -result [list {1 2 3 4} { 1 2 3 4 }]
test listrep-2.9 {
Appends to back of large shared list with no free space allocates new
list with space only at the back - lreplace version
} -constraints testlistrep -body {
set a [freeSpaceNone 1000]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lreplace $b $end+1 $end+1 1000]
validate $l
list [repStoreRefCount $b] $l [leadSpace $l] [expr {[tailSpace $l]>0}] [repStoreRefCount $l]
} -result [list 2 [irange 0 1000] 0 1 1]
test listrep-2.9.1 {
Appends to back of large shared list with no free space allocates new
list with space only at the back - linsert version
} -constraints testlistrep -body {
set a [freeSpaceNone 1000]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [linsert $b $end+1 1000 1001]
validate $l
list [repStoreRefCount $b] $l [leadSpace $l] [expr {[tailSpace $l]>0}] [repStoreRefCount $l]
} -result [list 2 [irange 0 1001] 0 1 1]
test listrep-2.9.2 {
Appends to back of large shared list with no free space allocates new
list with space only at the back - lappend version
} -constraints testlistrep -body {
set a [freeSpaceNone 1000]
set l [lrange $a $zero end]; # Ensure shared listrep
lappend l 1000
validate $l
list $l [leadSpace $l] [expr {[tailSpace $l]>0}] [repStoreRefCount $l]
} -result [list [irange 0 1000] 0 1 1]
test listrep-2.9.3 {
Appends to back of large shared list with no free space allocates new
list with space only at the back - lset version
} -constraints testlistrep -body {
set a [freeSpaceNone 1000]
set l [lrange $a $zero end]; # Ensure shared listrep
lset l $end+1 1000
validate $l
list $l [leadSpace $l] [expr {[tailSpace $l]>0}] [repStoreRefCount $l]
} -result [list [irange 0 1000] 0 1 1]
test listrep-2.10 {
Replacement of elements at front with same number in shared list results
in a new list store with more space in front than back - lreplace version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lreplace $b $zero $one 10 11]
validate $l
list [repStoreRefCount $b] $l [leadSpaceMore $l] [repStoreRefCount $l]
} -result [list 2 {10 11 2 3 4 5 6 7} 1 1]
test listrep-2.10.1 {
Replacement of elements at front with same number in shared list results
in a new list store with no extra space - lset version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set l [lrange $a $zero end]; # Ensure shared listrep
lset l $zero 10
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list {10 1 2 3 4 5 6 7} 0 0 1]
test listrep-2.11 {
Replacement of elements at front with fewer elements in shared list
results in a new list store with more space in front than back
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lreplace $b $zero $four 10]
validate $l
list [repStoreRefCount $b] $l [leadSpaceMore $l] [repStoreRefCount $l]
} -result [list 2 {10 5 6 7} 1 1]
test listrep-2.12 {
Replacement of elements at front with more elements in shared list
results in a new spanned list with more space in front
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lreplace $b $zero $one 10 11 12]
validate $l
list [repStoreRefCount $b] $l [leadSpaceMore $l] [repStoreRefCount $l]
} -result [list 2 {10 11 12 2 3 4 5 6 7} 1 1]
test listrep-2.13 {
Replacement of elements in middle with same number in shared list results
in a new list store with equal space in front and back - lreplace version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lreplace $b $one $two 10 11]
validate $l
list [repStoreRefCount $b] $l [spaceEqual $l] [repStoreRefCount $l]
} -result [list 2 {0 10 11 3 4 5 6 7} 1 1]
test listrep-2.13.1 {
Replacement of elements in middle with same number in shared list results
in a new list store with exact allocation - lset version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set l [lrange $a $zero end]; # Ensure shared listrep
lset l $one 10
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list {0 10 2 3 4 5 6 7} 0 0 1]
test listrep-2.14 {
Replacement of elements in middle with fewer elements in shared list
results in a new list store with equal space
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lreplace $b $one 5 10]
validate $l
list [repStoreRefCount $b] $l [spaceEqual $l] [repStoreRefCount $l]
} -result [list 2 {0 10 6 7} 1 1]
test listrep-2.15 {
Replacement of elements in middle with more elements in shared list
results in a new spanned list with space in front and back
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lreplace $b $one $two 10 11 12]
validate $l
list [repStoreRefCount $b] $l [spaceEqual $l] [repStoreRefCount $l]
} -result [list 2 {0 10 11 12 3 4 5 6 7} 1 1]
test listrep-2.16 {
Replacement of elements at back with same number in shared list results
in a new list store with more space in back than front - lreplace version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lreplace $b end-$one $end 10 11]
validate $l
list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l]
} -result [list 2 {0 1 2 3 4 5 10 11} 1 1]
test listrep-2.16.1 {
Replacement of elements at back with same number in shared list results
in a new list store with no extra - lreplace version
} -constraints testlistrep -body {
set a [freeSpaceNone]
set l [lrange $a $zero end]; # Ensure shared listrep
lset l $end 10
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list {0 1 2 3 4 5 6 10} 0 0 1]
test listrep-2.17 {
Replacement of elements at back with fewer elements in shared list
results in a new list store with more space in back than front
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lreplace $b end-$four $end 10]
validate $l
list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l]
} -result [list 2 {0 1 2 10} 1 1]
test listrep-2.18 {
Replacement of elements at back with more elements in shared list
results in a new list store with more space in back than front
} -constraints testlistrep -body {
set a [freeSpaceNone]
set b [lrange $a $zero end]; # Ensure shared listrep
set l [lreplace $b end-$four $end 10]
validate $l
list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l]
} -result [list 2 {0 1 2 10} 1 1]
#
# listrep-3.* - tests on unshared spanned listreps
test listrep-3.1 {
Inserts in front of unshared spanned list with room in front should just
shrink the lead space - linsert version
} -constraints testlistrep -body {
set l [linsert [freeSpaceBoth] $zero -2 -1]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange -2 7] 1 3 1]
test listrep-3.1.1 {
Inserts in front of unshared spanned list with room in front should just
shrink the lead space - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth] $zero -1 -2 -1]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange -2 7] 1 3 1]
test listrep-3.2 {
Inserts in front of unshared spanned list with insufficient room in front
but enough total freespace should redistribute free space - linsert version
} -constraints testlistrep -body {
set l [linsert [freeSpaceBoth 8 1 10] $zero -2 -1]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange -2 7] 5 4 1]
test listrep-3.2.1 {
Inserts in front of unshared spanned list with insufficient room in front
but enough total freespace should redistribute free space - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth 8 1 10] $zero -1 -2 -1]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange -2 7] 5 4 1]
test listrep-3.3 {
Inserts in front of unshared spanned list with insufficient total freespace
should reallocate with equal free space - linsert version
} -constraints testlistrep -body {
set l [linsert [freeSpaceBoth 8 1 1] $zero -3 -2 -1]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange -3 7] 6 5 1]
test listrep-3.3.1 {
Inserts in front of unshared spanned list with insufficient total freespace
should reallocate with equal free space - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth 8 1 1] $zero -1 -3 -2 -1]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange -3 7] 6 5 1]
test listrep-3.4 {
Inserts at back of unshared spanned list with room at back should not
reallocate - linsert version
} -constraints testlistrep -body {
set l [linsert [freeSpaceBoth] $end 8]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange 0 8] 3 2 1]
test listrep-3.4.1 {
Inserts at back of unshared spanned list with room at back should not
reallocate - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth] $end+1 $end+1 8 9]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange 0 9] 3 1 1]
test listrep-3.4.2 {
Inserts at back of unshared spanned list with room at back should not
reallocate - lappend version
} -constraints testlistrep -body {
set l [freeSpaceBoth]
lappend l 8 9 10
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange 0 10] 3 0 1]
test listrep-3.4.3 {
Inserts at back of unshared spanned list with room at back should not
reallocate - lset version
} -constraints testlistrep -body {
set l [freeSpaceBoth]
lset l $end+1 8
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange 0 8] 3 2 1]
test listrep-3.5 {
Inserts at back of unshared spanned list with insufficient room in back
but enough total freespace should redistribute free space - linsert version
} -constraints testlistrep -body {
set l [linsert [freeSpaceBoth 8 10 1] $end 8 9]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange 0 9] 5 4 1]
test listrep-3.5.1 {
Inserts at back of unshared spanned list with insufficient room in back
but enough total freespace should redistribute free space - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth 8 10 1] $end+1 $end+1 8 9]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange 0 9] 5 4 1]
test listrep-3.5.2 {
Inserts at back of unshared spanned list with insufficient room in back
but enough total freespace should redistribute free space - lappend version
} -constraints testlistrep -body {
set l [freeSpaceBoth 8 10 1]
lappend l 8 9
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange 0 9] 5 4 1]
test listrep-3.5.3 {
Inserts at back of unshared spanned list with insufficient room in back
but enough total freespace should redistribute free space - lset version
} -constraints testlistrep -body {
set l [freeSpaceBoth 8 10 0]
lset l $end+1 8
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange 0 8] 5 4 1]
test listrep-3.6 {
Inserts in back of unshared spanned list with insufficient total freespace
should reallocate with all *additional* space at back. Note this differs
from the insert in front case because here we realloc(). - linsert version
} -constraints testlistrep -body {
set l [linsert [freeSpaceBoth 8 1 1] $end 8 9 10]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange 0 10] 1 10 1]
test listrep-3.6.1 {
Inserts in back of unshared spanned list with insufficient total freespace
should reallocate with all *additional* space at back. Note this differs
from the insert in front case because here we realloc() - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth 8 1 1] $end+1 $end+1 8 9 10]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange 0 10] 1 10 1]
test listrep-3.6.2 {
Inserts in back of unshared spanned list with insufficient total freespace
should reallocate with all *additional* space at back. Note this differs
from the insert in front case because here we realloc() - lappend version
} -constraints testlistrep -body {
set l [freeSpaceBoth 8 1 1]
lappend l 8 9 10
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange 0 10] 1 10 1]
test listrep-3.6.3 {
Inserts in back of unshared spanned list with insufficient total freespace
should reallocate with all *additional* space at back. Note this differs
from the insert in front case because here we realloc() - lset version
} -constraints testlistrep -body {
set l [freeSpaceNone]
lset l $end+1 8
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange 0 8] 0 9 1]
test listrep-3.7 {
Inserts in front half of unshared spanned list with room in front should not
reallocate and should move front segment
} -constraints testlistrep -body {
set l [linsert [freeSpaceBoth] $one -2 -1]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list {0 -2 -1 1 2 3 4 5 6 7} 1 3 1]
test listrep-3.8 {
Inserts in front half of unshared spanned list with insufficient leading
space but with enough tail space - linsert version
} -constraints testlistrep -body {
set l [linsert [freeSpaceBoth 8 1 5] $one -2 -1]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list {0 -2 -1 1 2 3 4 5 6 7} 1 3 1]
test listrep-3.8.1 {
Inserts in front half of unshared spanned list with insufficient leading
space but with enough tail space - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth 8 1 5] $one -1 -2 -1]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list {0 -2 -1 1 2 3 4 5 6 7} 1 3 1]
test listrep-3.9 {
Inserts in front half of unshared spanned list with sufficient total
free space - linsert version
} -constraints testlistrep -body {
set l [linsert [freeSpaceBoth 8 2 2] $one -3 -2 -1]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 0 1 1]
test listrep-3.9.1 {
Inserts in front half of unshared spanned list with sufficient total
free space - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth 8 2 2] $one -1 -3 -2 -1]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 0 1 1]
test listrep-3.10 {
Inserts in front half of unshared spanned list with insufficient total space.
Note use of realloc() means new space will be at the back - linsert version
} -constraints testlistrep -body {
set l [linsert [freeSpaceBoth 8 1 1] $one -3 -2 -1]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 1 10 1]
test listrep-3.10.1 {
Inserts in front half of unshared spanned list with insufficient total space.
Note use of realloc() means new space will be at the back - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth 8 1 1] $one -1 -3 -2 -1]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 1 10 1]
test listrep-3.11 {
Inserts in back half of unshared spanned list with room in back should not
reallocate and should move back segment - linsert version
} -constraints testlistrep -body {
set l [linsert [freeSpaceBoth] $end-$one 8 9]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list {0 1 2 3 4 5 6 8 9 7} 3 1 1]
test listrep-3.11.1 {
Inserts in back half of unshared spanned list with room in back should not
reallocate and should move back segment - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth] $end -1 8 9]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list {0 1 2 3 4 5 6 8 9 7} 3 1 1]
test listrep-3.12 {
Inserts in back half of unshared spanned list with insufficient tail
space but with enough leading space - linsert version
} -constraints testlistrep -body {
set l [linsert [freeSpaceBoth 8 5 1] $end-$one 8 9]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list {0 1 2 3 4 5 6 8 9 7} 3 1 1]
test listrep-3.12.1 {
Inserts in back half of unshared spanned list with insufficient tail
space but with enough leading space - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth 8 5 1] $end -1 8 9]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list {0 1 2 3 4 5 6 8 9 7} 3 1 1]
test listrep-3.13 {
Inserts in back half of unshared spanned list with sufficient total
free space - linsert version
} -constraints testlistrep -body {
set l [linsert [freeSpaceBoth 8 2 2] $end-$one 8 9 10]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list {0 1 2 3 4 5 6 8 9 10 7} 0 1 1]
test listrep-3.13.1 {
Inserts in back half of unshared spanned list with sufficient total
free space - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth 8 2 2] $end -1 8 9 10]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list {0 1 2 3 4 5 6 8 9 10 7} 0 1 1]
test listrep-3.14 {
Inserts in back half of unshared spanned list with insufficient
total space. Note use of realloc() means new space will be at the
back - linsert version
} -constraints testlistrep -body {
set l [linsert [freeSpaceBoth 8 1 1] $end-$one 8 9 10]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list {0 1 2 3 4 5 6 8 9 10 7} 1 10 1]
test listrep-3.14.1 {
Inserts in back half of unshared spanned list with insufficient
total space. Note use of realloc() means new space will be at the
back - lrepalce version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth 8 1 1] $end -1 8 9 10]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list {0 1 2 3 4 5 6 8 9 10 7} 1 10 1]
test listrep-3.15 {
Deletes from front of small unshared span list results in elements
moved up front and span removal - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth] $zero $zero]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l]
} -result [list {1 2 3 4 5 6 7} 0 7 0]
test listrep-3.15.1 {
Deletes from front of small unshared span list results in elements
moved up front and span removal - lremove version
} -constraints testlistrep -body {
set l [lremove [freeSpaceBoth] $zero $one]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l]
} -result [list {2 3 4 5 6 7} 0 8 0]
test listrep-3.15.2 {
Deletes from front of small unshared span list results in elements
moved up front and span removal - lrange version
} -constraints testlistrep -body {
set l [lrange [freeSpaceBoth] $one $end]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l]
} -result [list {1 2 3 4 5 6 7} 0 7 0]
test listrep-3.15.3 {
Deletes from front of small unshared span list results in elements
moved up front and span removal - lassign version
} -constraints testlistrep -body {
set l [lassign [freeSpaceBoth] e]
validate $l
list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l]
} -result [list 0 {1 2 3 4 5 6 7} 0 7 0]
test listrep-3.15.4 {
Deletes from front of small unshared span list results in elements
moved up front and span removal - lpop version
} -constraints testlistrep -body {
set l [freeSpaceBoth]
set e [lpop l $zero]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l]
} -result [list {1 2 3 4 5 6 7} 0 7 0]
test listrep-3.16 {
Deletes from front of large unshared span list results in another
span - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth 1000 10 10] $zero $one]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 12 998]
} -result [list [irange 2 999] 12 10 1]
test listrep-3.16.1 {
Deletes from front of large unshared span list results in another
span - lremove version
} -constraints testlistrep -body {
set l [lremove [freeSpaceBoth 1000 10 10] $zero $one]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 12 998]
} -result [list [irange 2 999] 12 10 1]
test listrep-3.16.2 {
Deletes from front of large unshared span list results in another
span - lrange version
} -constraints testlistrep -body {
set l [lrange [freeSpaceBoth 1000 10 10] $two $end]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 12 998]
} -result [list [irange 2 999] 12 10 1]
test listrep-3.16.3 {
Deletes from front of large unshared span list results in another
span - lassign version
} -constraints testlistrep -body {
set l [lassign [freeSpaceBoth 1000 10 10] e]
validate $l
list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l 11 999]
} -result [list 0 [irange 1 999] 11 10 1]
test listrep-3.16.4 {
Deletes from front of large unshared span list results in another
span - lpop version
} -constraints testlistrep -body {
set l [freeSpaceBoth 1000 10 10]
set e [lpop l $zero]
validate $l
list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l 11 999]
} -result [list 0 [irange 1 999] 11 10 1]
test listrep-3.17 {
Deletes from back of small unshared span list results in new store
without span - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth] $end $end]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l]
} -result [list {0 1 2 3 4 5 6} 0 7 0]
test listrep-3.17.1 {
Deletes from back of small unshared span list results in new store
without span - lremove version
} -constraints testlistrep -body {
set l [lremove [freeSpaceBoth] $end]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l]
} -result [list {0 1 2 3 4 5 6} 0 7 0]
test listrep-3.17.2 {
Deletes from back of small unshared span list results in new store
without span - lrange version
} -constraints testlistrep -body {
set l [lrange [freeSpaceBoth] $zero $end-1]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l]
} -result [list {0 1 2 3 4 5 6} 0 7 0]
test listrep-3.17.3 {
Deletes from back of small unshared span list results in new store
without span - lpop version
} -constraints testlistrep -body {
set l [freeSpaceBoth]
set e [lpop l]
validate $l
list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l]
} -result [list 7 {0 1 2 3 4 5 6} 0 7 0]
test listrep-3.18 {
Deletes from back of large unshared span list results in another
span - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth 1000 10 10] $end-1 $end]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 10 998]
} -result [list [irange 0 997] 10 12 1]
test listrep-3.18.1 {
Deletes from back of large unshared span list results in another
span - lremove version
} -constraints testlistrep -body {
set l [lremove [freeSpaceBoth 1000 10 10] $end-1 $end]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 10 998]
} -result [list [irange 0 997] 10 12 1]
test listrep-3.18.2 {
Deletes from back of large unshared span list results in another
span - lrange version
} -constraints testlistrep -body {
set l [lrange [freeSpaceBoth 1000 10 10] $zero $end-2]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 10 998]
} -result [list [irange 0 997] 10 12 1]
test listrep-3.18.3 {
Deletes from back of large unshared span list results in another
span - lpop version
} -constraints testlistrep -body {
set l [freeSpaceBoth 1000 10 10]
set e [lpop l]
validate $l
list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l 10 999]
} -result [list 999 [irange 0 998] 10 11 1]
test listrep-3.19 {
Deletes from front half of small unshared span list results in
movement of smaller front segment - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth] $one $two]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 5 6]
} -result [list {0 3 4 5 6 7} 5 3 1]
test listrep-3.19.1 {
Deletes from front half of small unshared span list results in
movement of smaller front segment - lremove version
} -constraints testlistrep -body {
set l [lremove [freeSpaceBoth] $one $two]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 5 6]
} -result [list {0 3 4 5 6 7} 5 3 1]
test listrep-3.20 {
Deletes from front half of large unshared span list results in
movement of smaller front segment - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth 1000 10 10] $one $two]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 12 998]
} -result [list [list 0 {*}[irange 3 999]] 12 10 1]
test listrep-3.20.1 {
Deletes from front half of large unshared span list results in
movement of smaller front segment - lremove version
} -constraints testlistrep -body {
set l [lremove [freeSpaceBoth 1000 10 10] $one $two]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 12 998]
} -result [list [list 0 {*}[irange 3 999]] 12 10 1]
test listrep-3.21 {
Deletes from back half of small unshared span list results in
movement of smaller back segment - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth] $end-2 $end-1]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 3 6]
} -result [list {0 1 2 3 4 7} 3 5 1]
test listrep-3.21.1 {
Deletes from back half of small unshared span list results in
movement of smaller back segment - lremove version
} -constraints testlistrep -body {
set l [lremove [freeSpaceBoth] $end-2 $end-1]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 3 6]
} -result [list {0 1 2 3 4 7} 3 5 1]
test listrep-3.22 {
Deletes from back half of large unshared span list results in
movement of smaller back segment - lreplace version
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth 1000 10 10] $end-2 $end-1]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 10 998]
} -result [list [list {*}[irange 0 996] 999] 10 12 1]
test listrep-3.22.1 {
Deletes from back half of large unshared span list results in
movement of smaller back segment - lremove version
} -constraints testlistrep -body {
set l [lremove [freeSpaceBoth 1000 10 10] $end-2 $end-1]
validate $l
list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 10 998]
} -result [list [list {*}[irange 0 996] 999] 10 12 1]
test listrep-3.23 {
Replacement of elements at front with same number elements in unshared
spanned list is in-place - lreplace version
} -body {
set l [lreplace [freeSpaceBoth] $zero $one 10 11]
list $l [leadSpace $l] [tailSpace $l]
} -result [list {10 11 2 3 4 5 6 7} 3 3]
test listrep-3.23.1 {
Replacement of elements at front with same number elements in unshared
spanned list is in-place - lset version
} -body {
set l [freeSpaceBoth]
lset l $zero 10
list $l [leadSpace $l] [tailSpace $l]
} -result [list {10 1 2 3 4 5 6 7} 3 3]
test listrep-3.24 {
Replacement of elements at front with fewer elements in unshared
spanned list expands leading space - lreplace version
} -body {
set l [lreplace [freeSpaceBoth] $zero $four 10]
list $l [leadSpace $l] [tailSpace $l]
} -result [list {10 5 6 7} 7 3]
test listrep-3.25 {
Replacement of elements at front with more elements in unshared
spanned list with sufficient leading space shrinks leading space
} -body {
set l [lreplace [freeSpaceBoth] $zero $one 10 11 12]
list $l [leadSpace $l] [tailSpace $l]
} -result [list {10 11 12 2 3 4 5 6 7} 2 3]
test listrep-3.26 {
Replacement of elements at front with more elements in unshared
spanned list with insufficient leading space but sufficient total
free space
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth 8 1 10] $zero $one 10 11 12 13]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list {10 11 12 13 2 3 4 5 6 7} 5 4 1]
test listrep-3.27 {
Replacement of elements at front in unshared spanned list with insufficient
total freespace should reallocate with equal free space
} -constraints testlistrep -body {
set l [lreplace [freeSpaceBoth 8 1 1] $zero $one 10 11 12 13 14]
validate $l
list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list {10 11 12 13 14 2 3 4 5 6 7} 6 5 1]
test listrep-3.28 {
Replacement of elements at back with same number of elements in unshared
spanned list is in-place - lreplace version
} -body {
set l [lreplace [freeSpaceBoth] $end-1 $end 10 11]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 1 2 3 4 5 10 11} 3 3]
test listrep-3.28.1 {
Replacement of elements at back with same number of elements in unshared
spanned list is in-place - lset version
} -body {
set l [freeSpaceBoth]
lset l $end 10
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 1 2 3 4 5 6 10} 3 3]
test listrep-3.29 {
Replacement of elements at back with fewer elements in unshared
spanned list expands tail space
} -body {
set l [lreplace [freeSpaceBoth] $end-2 $end 10]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 1 2 3 4 10} 3 5]
test listrep-3.30 {
Replacement of elements at back with more elements in unshared
spanned list with sufficient tail space shrinks tailspace
} -body {
set l [lreplace [freeSpaceBoth] $end-1 $end 10 11 12]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 1 2 3 4 5 10 11 12} 3 2]
test listrep-3.31 {
Replacement of elements at back with more elements in unshared spanned list
with insufficient tail space but enough total free space moves up the span
} -body {
set l [lreplace [freeSpaceBoth 8 2 2] $end-1 $end 10 11 12 13 14]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 1 2 3 4 5 10 11 12 13 14} 0 1]
test listrep-3.32 {
Replacement of elements at back with more elements in unshared spanned list
with insufficient total space reallocates with more room in the tail because
of realloc()
} -body {
set l [lreplace [freeSpaceBoth 8 1 1] $end-1 $end 10 11 12 13 14]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 1 2 3 4 5 10 11 12 13 14} 1 10]
test listrep-3.33 {
Replacement of elements in the middle in an unshared spanned list with
the same number of elements - lreplace version
} -body {
set l [lreplace [freeSpaceBoth] $two $four 10 11 12]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 1 10 11 12 5 6 7} 3 3]
test listrep-3.33.1 {
Replacement of elements in the middle in an unshared spanned list with
the same number of elements - lset version
} -body {
set l [freeSpaceBoth]
lset l $two 10
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 1 10 3 4 5 6 7} 3 3]
test listrep-3.34 {
Replacement of elements in an unshared spanned list with fewer elements
in the front half moves the front (smaller) segment
} -body {
set l [lreplace [freeSpaceBoth] $two $four 10 11]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 1 10 11 5 6 7} 4 3]
test listrep-3.35 {
Replacement of elements in an unshared spanned list with fewer elements
in the back half moves the tail (smaller) segment
} -body {
set l [lreplace [freeSpaceBoth] $end-2 $end-1 10]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 1 2 3 4 10 7} 3 4]
test listrep-3.36 {
Replacement of elements in an unshared spanned list with more elements
when both front and back have room should move the smaller segment
(front case)
} -body {
set l [lreplace [freeSpaceBoth] $one $two 8 9 10]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 8 9 10 3 4 5 6 7} 2 3]
test listrep-3.37 {
Replacement of elements in an unshared spanned list with more elements
when both front and back have room should move the smaller segment
(back case)
} -body {
set l [lreplace [freeSpaceBoth] $end-2 $end-1 8 9 10]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 1 2 3 4 8 9 10 7} 3 2]
test listrep-3.38 {
Replacement of elements in an unshared spanned list with more elements
when only front has room
} -body {
set l [lreplace [freeSpaceBoth 8 3 1] $end-1 $end-1 8 9 10]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 1 2 3 4 5 8 9 10 7} 1 1]
test listrep-3.39 {
Replacement of elements in an unshared spanned list with more elements
when only back has room
} -body {
set l [lreplace [freeSpaceBoth 8 1 3] $one $one 8 9 10]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 8 9 10 2 3 4 5 6 7} 1 1]
test listrep-3.40 {
Replacement of elements in an unshared spanned list with more elements
when neither send has enough room by itself
} -body {
set l [lreplace [freeSpaceBoth] $one $one 8 9 10 11 12]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 8 9 10 11 12 2 3 4 5 6 7} 1 1]
test listrep-3.41 {
Replacement of elements in an unshared spanned list with more elements
when there is not enough free space results in new allocation. The back
end has more space because of realloc()
} -body {
set l [lreplace [freeSpaceBoth 8 1 1] $one $one 8 9 10 11 12]
validate $l
list $l [leadSpace $l] [tailSpace $l]
} -result [list {0 8 9 10 11 12 2 3 4 5 6 7} 1 11]
#
# 4.* - tests on shared spanned lists
test listrep-4.1 {
Inserts in front of shared spanned list with used elements in lead space
creates new list rep with more lead than tail space - linsert version
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set spanl [lrange $master $two $end-2]
set l [linsert $spanl $zero -1]
validate $l
list $master $spanl $l [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $master] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 0 999] [irange 2 997] [list -1 {*}[irange 2 997]] 1 1 2 2 1]
test listrep-4.1.1 {
Inserts in front of shared spanned list with used elements in lead space
creates new list rep with more lead than tail space - lreplace version
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set spanl [lrange $master $two $end-2]
set l [lreplace $spanl $zero -1 -2]
validate $l
list $master $spanl $l [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $master] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 0 999] [irange 2 997] [list -2 {*}[irange 2 997]] 1 1 2 2 1]
test listrep-4.2 {
Inserts in front of shared spanned list with orphaned leading elements
allocate a new list rep with more lead than tail space - linsert version
TODO - ideally this should garbage collect the orphans and reuse the lead space
but that needs a "lprepend" command else the listrep operand is shared and hence
orphans cannot be freed
} -constraints testlistrep -body {
set master [freeSpaceLead 1000 100]
set spanl [lrange $master $two $end-2]
unset master; # So elements at 0, 1 are not used
set l [linsert $spanl $zero -1]
validate $l
list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 997] [list -1 {*}[irange 2 997]] 0 1 1 1 1]
test listrep-4.2.1 {
Inserts in front of shared spanned list with orphaned leading elements
allocate a new list rep with more lead than tail space - lreplace version
TODO - ideally this should garbage collect the orphans and reuse the lead space
but that needs a "lprepend" command else the listrep operand is shared and hence
orphans cannot be freed
} -constraints testlistrep -body {
set master [freeSpaceLead 1000 100]
set spanl [lrange $master $two $end-2]
unset master; # So elements at 0, 1 are not used
set l [lreplace $spanl $zero -1 -2]
validate $l
list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 997] [list -2 {*}[irange 2 997]] 0 1 1 1 1]
test listrep-4.3 {
Inserts in front of shared spanned list where span is at front of used
space reuses the same list store - linsert version
} -constraints testlistrep -body {
set master [freeSpaceLead 1000 100]
set spanl [lrange $master $zero $end-2]
set l [linsert $spanl $zero -1]
validate $l
list $spanl $l [sameStore $spanl $l] [leadSpace $l] [tailSpace $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 0 997] [irange -1 997] 1 99 0 1 3 3]
test listrep-4.3.1 {
Inserts in front of shared spanned list where span is at front of used
space reuses the same list store - lreplace version
} -constraints testlistrep -body {
set master [freeSpaceLead 1000 100]
set spanl [lrange $master $zero $end-2]
set l [lreplace $spanl $zero -1 -1]
validate $l
list $spanl $l [sameStore $spanl $l] [leadSpace $l] [tailSpace $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 0 997] [irange -1 997] 1 99 0 1 3 3]
test listrep-4.4 {
Inserts in front of shared spanned list where span is at front of used
space allocates new listrep if lead space insufficient even if total free space
is sufficient. New listrep should have more lead space than tail space.
- linsert version
} -constraints testlistrep -body {
set master [freeSpaceBoth 1000 2]
set spanl [lrange $master $zero $end-2]
set l [linsert $spanl $zero -3 -2 -1]
validate $l
list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 0 997] [irange -3 997] 0 1 1 2 1]
test listrep-4.4.1 {
Inserts in front of shared spanned list where span is at front of used
space allocates new listrep if lead space insufficient even if total free space
is sufficient. New listrep should have more lead space than tail space.
- lreplace version
} -constraints testlistrep -body {
set master [freeSpaceBoth 1000 2]
set spanl [lrange $master $zero $end-2]
set l [lreplace $spanl $zero -1 -3 -2 -1]
validate $l
list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 0 997] [irange -3 997] 0 1 1 2 1]
test listrep-4.5 {
Inserts in back of shared spanned list where span is at end of used space
still allocates a new listrep and trailing space is more than leading space
- linsert version
} -constraints testlistrep -body {
set master [freeSpaceBoth 1000 2]
set spanl [lrange $master $two $end]
set l [linsert $spanl $end 1000]
validate $l
list $spanl $l [sameStore $spanl $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 999] [irange 2 1000] 0 1 1 2 1]
test listrep-4.5.1 {
Inserts in back of shared spanned list where span is at end of used space
still allocates a new listrep and trailing space is more than leading space
- lreplace version
} -constraints testlistrep -body {
set master [freeSpaceBoth 1000 2]
set spanl [lrange $master $two $end]
set l [lreplace $spanl $end+1 $end+1 1000]
validate $l
list $spanl $l [sameStore $spanl $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 999] [irange 2 1000] 0 1 1 2 1]
test listrep-4.5.2 {
Inserts in back of shared spanned list where span is at end of used space
still allocates a new listrep and trailing space is more than leading space
- lappend version
} -constraints testlistrep -body {
set master [freeSpaceBoth 1000 2]
set l [lrange $master $two $end]
lappend l 1000
validate $l
list $l [sameStore $master $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $l]
} -result [list [irange 2 1000] 0 1 1 1]
test listrep-4.5.3 {
Inserts in back of shared spanned list where span is at end of used space
still allocates a new listrep and trailing space is more than leading space
- lset version
} -constraints testlistrep -body {
set master [freeSpaceBoth 1000 2]
set l [lrange $master $two $end]
lset l $end+1 1000
validate $l
list $l [sameStore $master $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $l]
} -result [list [irange 2 1000] 0 1 1 1]
test listrep-4.6 {
Inserts in middle of shared spanned list allocates a new listrep with equal
lead and tail space - linsert version
} -constraints testlistrep -body {
set master [freeSpaceBoth 1000 2]
set spanl [lrange $master $two $end-2]
set i 200
set l [linsert $spanl $i 1000]
validate $l
list $spanl $l [sameStore $spanl $l] [spaceEqual $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 997] [concat [irange 2 201] 1000 [irange 202 997]] 0 1 1 2 1]
test listrep-4.6.1 {
Inserts in middle of shared spanned list allocates a new listrep with equal
lead and tail space - lreplace version
} -constraints testlistrep -body {
set master [freeSpaceBoth 1000 2]
set spanl [lrange $master $two $end-2]
set i 200
set l [lreplace $spanl $i -1 1000]
validate $l
list $spanl $l [sameStore $spanl $l] [spaceEqual $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 997] [concat [irange 2 201] 1000 [irange 202 997]] 0 1 1 2 1]
test listrep-4.7 {
Deletes from front of shared spanned list do not create a new allocation
- lreplace version
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set spanl [lrange $master $two $end-2]
set l [lreplace $spanl $zero $one]
validate $l
list $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 997] [irange 4 997] 1 1 3 3]
test listrep-4.7.1 {
Deletes from front of shared spanned list do not create a new allocation
- lremove version
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set spanl [lrange $master $two $end-2]
set l [lremove $spanl $zero $one]
validate $l
list $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 997] [irange 4 997] 1 1 3 3]
test listrep-4.7.2 {
Deletes from front of shared spanned list do not create a new allocation
- lrange version
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set spanl [lrange $master $two $end-2]
set l [lrange $spanl $two $end]
validate $l
list $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 997] [irange 4 997] 1 1 3 3]
test listrep-4.7.3 {
Deletes from front of shared spanned list do not create a new allocation
- lassign version
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set spanl [lrange $master $two $end-2]
set l [lassign $spanl e]
validate $l
list $e $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list 2 [irange 2 997] [irange 3 997] 1 1 3 3]
test listrep-4.7.4 {
Deletes from front of shared spanned list do not create a new allocation
- lpop version
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set l [lrange $master $two $end-2]
set e [lpop l $zero]
validate $l
list $e $l [sameStore $master $l] [hasSpan $l] [repStoreRefCount $l]
} -result [list 2 [irange 3 997] 1 1 2]
test listrep-4.8 {
Deletes from end of shared spanned list do not create a new allocation
- lreplace version
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set spanl [lrange $master $two $end-2]
set l [lreplace $spanl $end-1 $end]
validate $l
list $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 997] [irange 2 995] 1 1 3 3]
test listrep-4.8.1 {
Deletes from end of shared spanned list do not create a new allocation
- lremove version
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set spanl [lrange $master $two $end-2]
set l [lremove $spanl $end-1 $end]
validate $l
list $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 997] [irange 2 995] 1 1 3 3]
test listrep-4.8.2 {
Deletes from end of shared spanned list do not create a new allocation
- lrange version
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set spanl [lrange $master $two $end-2]
set l [lrange $spanl 0 $end-2]
validate $l
list $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 997] [irange 2 995] 1 1 3 3]
test listrep-4.8.3 {
Deletes from end of shared spanned list do not create a new allocation
- lpop version
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set l [lrange $master $two $end-2]
set e [lpop l]
validate $l
list $e $l [sameStore $master $l] [hasSpan $l] [repStoreRefCount $l]
} -result [list 997 [irange 2 996] 1 1 2]
test listrep-4.9 {
Deletes from middle of shared spanned list creates a new allocation with
equal free space at front and back - lreplace version
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set spanl [lrange $master $two $end-2]
set i 500
set l [lreplace $spanl $i $i]
validate $l
list $spanl $l [sameStore $spanl $l] [hasSpan $l] [spaceEqual $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 997] [concat [irange 2 501] [irange 503 997]] 0 1 1 2 1]
test listrep-4.9.1 {
Deletes from middle of shared spanned list creates a new allocation with
equal free space at front and back - lremove version
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set spanl [lrange $master $two $end-2]
set i 500
set l [lremove $spanl $i $i]
validate $l
list $spanl $l [sameStore $spanl $l] [hasSpan $l] [spaceEqual $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 997] [concat [irange 2 501] [irange 503 997]] 0 1 1 2 1]
test listrep-4.9.2 {
Deletes from middle of shared spanned list creates a new allocation with
equal free space at front and back - lpop version
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set l [lrange $master $two $end-2]
set i 500
set e [lpop l $i]
validate $l
list $e $l [sameStore $master $l] [hasSpan $l] [spaceEqual $l] [repStoreRefCount $l]
} -result [list 502 [concat [irange 2 501] [irange 503 997]] 0 1 1 1]
test listrep-4.10 {
Replacements with same number of elements at front of shared spanned list
create a new allocation with more space in front - lreplace version
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set spanl [lrange $master $two $end-2]
set l [lreplace $spanl $zero $one -2 -1]
validate $l
list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 997] [concat {-2 -1} [irange 4 997]] 0 1 1 2 1]
test listrep-4.10.1 {
Replacements with same number of elements at front of shared spanned list
create a new allocation with exact size
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set l [lrange $master $two $end-2]
lset l $zero -1
validate $l
list $l [sameStore $master $l] [hasSpan $l] [repStoreRefCount $l]
} -result [list [concat {-1} [irange 3 997]] 0 0 1]
test listrep-4.11 {
Replacements with fewer elements at front of shared spanned list
create a new allocation with more space in front
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set spanl [lrange $master $two $end-2]
set l [lreplace $spanl $zero $one -1]
validate $l
list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 997] [concat {-1} [irange 4 997]] 0 1 1 2 1]
test listrep-4.12 {
Replacements with more elements at front of shared spanned list
create a new allocation with more space in front
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set spanl [lrange $master $two $end-2]
set l [lreplace $spanl $zero $one -3 -2 -1]
validate $l
list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 997] [concat {-3 -2 -1} [irange 4 997]] 0 1 1 2 1]
test listrep-4.13 {
Replacements with same number of elements at back of shared spanned list
create a new allocation with more space in back - lreplace version
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set spanl [lrange $master $two $end-2]
set l [lreplace $spanl $end-1 $end 1000 1001]
validate $l
list $spanl $l [sameStore $spanl $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 997] [concat [irange 2 995] {1000 1001}] 0 1 1 2 1]
test listrep-4.13.1 {
Replacements with same number of elements at back of shared spanned list
create a new exact allocation with no span - lset version
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set l [lrange $master $two $end-2]
lset l $end 1000
validate $l
list $l [sameStore $master $l] [tailSpace $l] [hasSpan $l] [repStoreRefCount $l]
} -result [list [concat [irange 2 996] {1000}] 0 0 0 1]
test listrep-4.14 {
Replacements with fewer elements at back of shared spanned list
create a new allocation with more space in back
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set spanl [lrange $master $two $end-2]
set l [lreplace $spanl $end-1 $end 1000]
validate $l
list $spanl $l [sameStore $spanl $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 997] [concat [irange 2 995] {1000}] 0 1 1 2 1]
test listrep-4.15 {
Replacements with more elements at back of shared spanned list
create a new allocation with more space in back
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set spanl [lrange $master $two $end-2]
set l [lreplace $spanl $end-1 $end 1000 1001 1002]
validate $l
list $spanl $l [sameStore $spanl $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 997] [concat [irange 2 995] {1000 1001 1002}] 0 1 1 2 1]
test listrep-4.16 {
Replacements with same number of elements in middle of shared spanned list
create a new allocation with equal lead and tail sapce
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set spanl [lrange $master $two $end-2]
set l [lreplace $spanl $one $two -2 -1]
validate $l
list $spanl $l [sameStore $spanl $l] [spaceEqual $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 997] [concat {2 -2 -1} [irange 5 997]] 0 1 1 2 1]
test listrep-4.16.1 {
Replacements with same number of elements in middle of shared spanned list
create a new exact allocation - lset version
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set l [lrange $master $two $end-2]
lset l $one -2
validate $l
list $l [sameStore $master $l] [hasSpan $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [concat {2 -2} [irange 4 997]] 0 0 0 1]
test listrep-4.17 {
Replacements with fewer elements in middle of shared spanned list
create a new allocation with equal lead and tail sapce
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set spanl [lrange $master $two $end-2]
set l [lreplace $spanl $end-2 $end-1 1000]
validate $l
list $spanl $l [sameStore $spanl $l] [spaceEqual $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 997] [concat [irange 2 994] {1000 997}] 0 1 1 2 1]
test listrep-4.18 {
Replacements with more elements in middle of shared spanned list
create a new allocation with equal lead and tail sapce
} -constraints testlistrep -body {
set master [freeSpaceNone 1000]
set spanl [lrange $master $two $end-2]
set l [lreplace $spanl $end-2 $end-1 1000 1001 1002]
validate $l
list $spanl $l [sameStore $spanl $l] [spaceEqual $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l]
} -result [list [irange 2 997] [concat [irange 2 994] {1000 1001 1002 997}] 0 1 1 2 1]
# 5.* - tests on shared Tcl_Obj
# Tests when Tcl_Obj is shared but listrep is not. This is to ensure that
# checks for shared values check the Tcl_Obj reference counts in addition to
# the list internal representation reference counts. Probably some or all
# cases are already covered elsewhere but easier to just test than look.
test listrep-5.1 {
Verify that operation on a shared Tcl_Obj with a single-ref, spanless
list representation only modifies the target object - lappend version
} -constraints testlistrep -body {
set l [freeSpaceNone]
set l2 $l
set same [sameStore $l $l2]
lappend l 8
list $same $l $l2 [sameStore $l $l2]
} -result [list 1 [irange 0 8] [irange 0 7] 0]
test listrep-5.1.1 {
Verify that operation on a shared Tcl_Obj with a single-ref, spanless
list representation only modifies the target object - lset version
} -constraints testlistrep -body {
set l [freeSpaceNone]
set l2 $l
set same [sameStore $l $l2]
lset l $end+1 8
list $same $l $l2 [sameStore $l $l2]
} -result [list 1 [irange 0 8] [irange 0 7] 0]
test listrep-5.1.2 {
Verify that operation on a shared Tcl_Obj with a single-ref, spanless
list representation only modifies the target object - lpop version
} -constraints testlistrep -body {
set l [freeSpaceNone]
set l2 $l
set same [sameStore $l $l2]
lpop l
list $same $l $l2 [sameStore $l $l2] [hasSpan $l]
} -result [list 1 [irange 0 6] [irange 0 7] 0 0]
test listrep-5.2 {
Verify that operation on a shared Tcl_Obj with a single-ref, spanned
list representation only modifies the target object - lappend version
} -constraints testlistrep -body {
set l [freeSpaceBoth 1000 10 10]
set l2 $l
set same [sameStore $l $l2]
lappend l 1000
list $same $l $l2 [sameStore $l $l2] [hasSpan $l] [hasSpan $l2]
} -result [list 1 [irange 0 1000] [irange 0 999] 0 1 1]
test listrep-5.2.1 {
Verify that operation on a shared Tcl_Obj with a single-ref, spanned
list representation only modifies the target object - lset version
} -constraints testlistrep -body {
set l [freeSpaceBoth 1000 10 10]
set l2 $l
set same [sameStore $l $l2]
lset l $end+1 1000
list $same $l $l2 [sameStore $l $l2] [hasSpan $l] [hasSpan $l2]
} -result [list 1 [irange 0 1000] [irange 0 999] 0 1 1]
test listrep-5.2.2 {
Verify that operation on a shared Tcl_Obj with a single-ref, spanned
list representation only modifies the target object - lpop version
} -constraints testlistrep -body {
set l [freeSpaceNone 1000]
set l2 $l
set same [sameStore $l $l2]
lpop l
list $same $l $l2 [sameStore $l $l2] [hasSpan $l] [hasSpan $l2]
} -result [list 1 [irange 0 998] [irange 0 999] 1 1 0]
#
# 6.* - tests when lists contain zombies.
# The list implementation does lazy freeing in some cases so the list store
# contain Tcl_Obj's that are not actually referenced by any list (zombies).
# These are to be freed next time the list store is modified by a list
# operation as long as it is no longer shared.
test listrep-6.1 {
Verify that zombies are freed up - linsert at front
} -constraints testlistrep -body {
set l [zombieSample 200 10 10]
set addr [storeAddress $l]
# set l {} is for reference counts to drop to 1
set l [linsert $l[set l {}] $zero -1]
list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [list -1 {*}[irange 10 209]] 1 9 10 1]
test listrep-6.1.1 {
Verify that zombies are freed up - linsert in middle
} -constraints testlistrep -body {
set l [zombieSample 200 10 10]
set addr [storeAddress $l]
# set l {} is for reference counts to drop to 1
set l [linsert $l[set l {}] $one -1]
list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [list 10 -1 {*}[irange 11 209]] 1 9 10 1]
test listrep-6.1.2 {
Verify that zombies are freed up - linsert at end
} -constraints testlistrep -body {
set l [zombieSample 200 10 10]
set addr [storeAddress $l]
# set l {} is for reference counts to drop to 1
set l [linsert $l[set l {}] $end 210]
list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange 10 210] 1 10 9 1]
test listrep-6.2 {
Verify that zombies are freed up - lrange version (whole)
} -constraints testlistrep -body {
set l [zombieSample 200 10 10]
set addr [storeAddress $l]
# set l {} is for reference counts to drop to 1
set l [lrange $l[set l {}] $zero $end]
list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange 10 209] 1 10 10 1]
test listrep-6.2.1 {
Verify that zombies are freed up - lrange version (subrange)
} -constraints testlistrep -body {
set l [zombieSample 200 10 10]
set addr [storeAddress $l]
# set l {} is for reference counts to drop to 1
set l [lrange $l[set l {}] $one $end-1]
list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange 11 208] 1 11 11 1]
test listrep-6.3 {
Verify that zombies are freed up - lassign version
} -constraints testlistrep -body {
set l [zombieSample 200 10 10]
set addr [storeAddress $l]
# set l {} is for reference counts to drop to 1
set l [lassign $l[set l {}] e]
list $e $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list 10 [irange 11 209] 1 11 10 1]
test listrep-6.4 {
Verify that zombies are freed up - lremove version (front)
} -constraints testlistrep -body {
set l [zombieSample 200 10 10]
set addr [storeAddress $l]
# set l {} is for reference counts to drop to 1
set l [lremove $l[set l {}] $zero]
list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange 11 209] 1 11 10 1]
test listrep-6.4.1 {
Verify that zombies are freed up - lremove version (back)
} -constraints testlistrep -body {
set l [zombieSample 200 10 10]
set addr [storeAddress $l]
# set l {} is for reference counts to drop to 1
set l [lremove $l[set l {}] $end]
list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange 10 208] 1 10 11 1]
test listrep-6.5 {
Verify that zombies are freed up - lreplace at front
} -constraints testlistrep -body {
set l [zombieSample 200 10 10]
set addr [storeAddress $l]
# set l {} is for reference counts to drop to 1
set l [lreplace $l[set l {}] $zero $one -3 -2 -1]
list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [list -3 -2 -1 {*}[irange 12 209]] 1 9 10 1]
test listrep-6.5.1 {
Verify that zombies are freed up - lreplace at back
} -constraints testlistrep -body {
set l [zombieSample 200 10 10]
set addr [storeAddress $l]
# set l {} is for reference counts to drop to 1
set l [lreplace $l[set l {}] $end-1 $end -1 -2 -3]
list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [list {*}[irange 10 207] -1 -2 -3] 1 10 9 1]
test listrep-6.6 {
Verify that zombies are freed up - lappend
} -constraints testlistrep -body {
set l [zombieSample 200 10 10]
set addr [storeAddress $l]
lappend l 210
list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange 10 210] 1 10 9 1]
test listrep-6.7 {
Verify that zombies are freed up - lpop version (front)
} -constraints testlistrep -body {
set l [zombieSample 200 10 10]
set addr [storeAddress $l]
set e [lpop l $zero]
list $e $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list 10 [irange 11 209] 1 11 10 1]
test listrep-6.7.1 {
Verify that zombies are freed up - lpop version (back)
} -constraints testlistrep -body {
set l [zombieSample 200 10 10]
set addr [storeAddress $l]
set e [lpop l]
list $e $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list 209 [irange 10 208] 1 10 11 1]
test listrep-6.8 {
Verify that zombies are freed up - lset version
} -constraints testlistrep -body {
set l [zombieSample 200 10 10]
set addr [storeAddress $l]
lset l $zero -1
list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [list -1 {*}[irange 11 209]] 1 10 10 1]
test listrep-6.8.1 {
Verify that zombies are freed up - lset version (back)
} -constraints testlistrep -body {
set l [zombieSample 200 10 10]
set addr [storeAddress $l]
lset l $end+1 210
list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
} -result [list [irange 10 210] 1 10 9 1]
# All done
::tcltest::cleanupTests
return
|
Changes to tests/lrepeat.test.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
}
test lrepeat-1.7 {Accept zero repetitions (TIP 323)} {
-body {
lrepeat 0 a b c
}
-result {}
}
| | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
}
test lrepeat-1.7 {Accept zero repetitions (TIP 323)} {
-body {
lrepeat 0 a b c
}
-result {}
}
test lrepeat-1.8 {Do not build enormous lists - Bug 2130992} -constraints knownBug -body {
lrepeat 0x10000000 a b c d e f g h
} -returnCodes error -match glob -result *
## Okay
test lrepeat-2.1 {normal cases} {
lrepeat 10 a
} {a a a a a a a a a a}
|
| ︙ | ︙ |
Changes to tests/oo.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 © 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. | | | 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 © 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 tcl::oo 1.3.0
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# The foundational objects oo::object and oo::class are sensitive to reference
# counting errors and are deallocated only when an interp is deleted, so in
|
| ︙ | ︙ |
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 © 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 © 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 tcl::oo 1.3.0
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
|
| ︙ | ︙ |
Changes to tests/ooUtil.test.
1 2 3 4 5 6 7 8 9 10 11 | # This file contains a collection of tests for functionality originally # sourced from the ooutil package in Tcllib. Sourcing this file into Tcl runs # the tests and generates output for errors. No output means no errors were # found. # # Copyright © 2014-2016 Andreas Kupries # Copyright © 2018 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 18 19 |
# This file contains a collection of tests for functionality originally
# sourced from the ooutil package in Tcllib. Sourcing this file into Tcl runs
# the tests and generates output for errors. No output means no errors were
# found.
#
# Copyright © 2014-2016 Andreas Kupries
# Copyright © 2018 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 tcl::oo 1.3.0
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test ooUtil-1.1 {TIP 478: classmethod} -setup {
oo::class create parent
|
| ︙ | ︙ |
Changes to tests/proc.test.
| ︙ | ︙ | |||
407 408 409 410 411 412 413 414 415 416 417 418 419 420 |
test proc-7.5 {[631b4c45df] Crash in argument processing} {
binary scan A c val
proc foo [list [list from $val]] {}
rename foo {}
unset -nocomplain val
} {}
# cleanup
catch {rename p ""}
catch {rename t ""}
::tcltest::cleanupTests
return
| > > > > > > > | 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 |
test proc-7.5 {[631b4c45df] Crash in argument processing} {
binary scan A c val
proc foo [list [list from $val]] {}
rename foo {}
unset -nocomplain val
} {}
test proc-7.6 {[51d5f22997] Crash in argument processing} -cleanup {
rename foo {}
} -body {
proc foo {{x {}} {y {}} args} {}
foo
} -result {}
# cleanup
catch {rename p ""}
catch {rename t ""}
::tcltest::cleanupTests
return
|
| ︙ | ︙ |
Changes to tests/result.test.
| ︙ | ︙ | |||
105 106 107 108 109 110 111 |
set errorCode
} {{a b} c}
test result-6.0 {Bug 1209759} -constraints testreturn -body {
# Might panic if bug is not fixed.
proc foo {} {testreturn}
foo
| | | | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 |
set errorCode
} {{a b} c}
test result-6.0 {Bug 1209759} -constraints testreturn -body {
# Might panic if bug is not fixed.
proc foo {} {testreturn}
foo
} -result {}
test result-6.1 {Bug 1209759} -constraints testreturn -body {
# Might panic if bug is not fixed.
proc foo {} {catch {return -level 2}; testreturn}
foo
} -cleanup {
rename foo {}
} -result {}
test result-6.2 {Bug 1649062} -setup {
proc foo {} {
if {[catch {
return -code error -errorinfo custom -errorcode CUSTOM foo
} err]} {
return [list $err $::errorCode $::errorInfo]
}
|
| ︙ | ︙ |
Changes to tests/safe.test.
| ︙ | ︙ | |||
1170 1171 1172 1173 1174 1175 1176 |
safe::interpDelete $i
} -result {load of library for prefix Safepfx1 failed: can't use library in a safe interpreter: no Safepfx1_SafeInit procedure}
test safe-10.1.1 {testing statics loading} -constraints tcl::test -setup {
set i [safe::interpCreate]
} -body {
catch {interp eval $i {load {} Safepfx1}} m o
dict get $o -errorinfo
| | | 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 |
safe::interpDelete $i
} -result {load of library for prefix Safepfx1 failed: can't use library in a safe interpreter: no Safepfx1_SafeInit procedure}
test safe-10.1.1 {testing statics loading} -constraints tcl::test -setup {
set i [safe::interpCreate]
} -body {
catch {interp eval $i {load {} Safepfx1}} m o
dict get $o -errorinfo
} -cleanup {
unset -nocomplain m o
safe::interpDelete $i
} -result {load of library for prefix Safepfx1 failed: can't use library in a safe interpreter: no Safepfx1_SafeInit procedure
invoked from within
"load {} Safepfx1"
invoked from within
"interp eval $i {load {} Safepfx1}"}
|
| ︙ | ︙ | |||
1201 1202 1203 1204 1205 1206 1207 |
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {load of library for prefix Safepfx1 failed: can't use library in a safe interpreter: no Safepfx1_SafeInit procedure}
test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints tcl::test -body {
set i [safe::interpCreate -nestedloadok]
catch {interp eval $i {interp create x; load {} Safepfx1 x}} m o
dict get $o -errorinfo
| | | 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 |
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {load of library for prefix Safepfx1 failed: can't use library in a safe interpreter: no Safepfx1_SafeInit procedure}
test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints tcl::test -body {
set i [safe::interpCreate -nestedloadok]
catch {interp eval $i {interp create x; load {} Safepfx1 x}} m o
dict get $o -errorinfo
} -cleanup {
unset -nocomplain m o
safe::interpDelete $i
} -result {load of library for prefix Safepfx1 failed: can't use library in a safe interpreter: no Safepfx1_SafeInit procedure
invoked from within
"load {} Safepfx1 x"
invoked from within
"interp eval $i {interp create x; load {} Safepfx1 x}"}
|
| ︙ | ︙ | |||
1265 1266 1267 1268 1269 1270 1271 |
} -result foobar
test safe-11.7 {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
interp eval $i encoding convertfrom
} -returnCodes error -cleanup {
safe::interpDelete $i
| | | | | | | | 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 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 |
} -result foobar
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 ?-nocomplain? ?-failindex var? ?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
} -match glob -cleanup {
unset -nocomplain m o
safe::interpDelete $i
} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"
while executing
"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 ?-nocomplain? ?-failindex var? ?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
} -match glob -cleanup {
unset -nocomplain m o
safe::interpDelete $i
} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"
while executing
"encoding convertto"
invoked from within
"encoding convertto"
invoked from within
"interp eval $i encoding convertto"}
|
| ︙ | ︙ | |||
1617 1618 1619 1620 1621 1622 1623 |
set d [format %c 126]
file join {$p(:0:)} $d
}
} -cleanup {
safe::interpDelete $i
set env(HOME) $savedHOME
unset savedHOME
| | | | | | 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 |
set d [format %c 126]
file join {$p(:0:)} $d
}
} -cleanup {
safe::interpDelete $i
set env(HOME) $savedHOME
unset savedHOME
} -result {$p(:0:)/~}
test safe-16.6 {Bug 3529949: defang ~ in paths used by AliasGlob (2)} -setup {
set savedHOME $env(HOME)
set env(HOME) /foo/bar
set i [safe::interpCreate]
} -body {
$i eval {
set d [format %c 126]
file join {$p(:0:)/foo/bar} $d
}
} -cleanup {
safe::interpDelete $i
set env(HOME) $savedHOME
unset savedHOME
} -result {$p(:0:)/foo/bar/~}
test safe-16.7 {Bug 3529949: defang ~user in paths used by AliasGlob (1)} -setup {
set i [safe::interpCreate]
set user $tcl_platform(user)
} -body {
string map [list $user USER] [$i eval [list file join {$p(:0:)} ~$user]]
} -cleanup {
safe::interpDelete $i
unset user
} -result {$p(:0:)/~USER}
test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup {
set i [safe::interpCreate]
set user $tcl_platform(user)
} -body {
string map [list $user USER] [$i eval [list file join {$p(:0:)/foo/bar} ~$user]]
} -cleanup {
safe::interpDelete $i
unset user
} -result {$p(:0:)/foo/bar/~USER}
# cleanup
set ::auto_path $SaveAutoPath
unset SaveAutoPath TestsDir PathMapp
unset -nocomplain path
rename mapList {}
rename mapAndSortList {}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/string.test.
| ︙ | ︙ | |||
28 29 30 31 32 33 34 |
proc makeShared {s} {uplevel 1 [list lappend copy $s]; return $s}
# Some tests require the testobj command
testConstraint testobj [expr {[info commands testobj] ne {}}]
testConstraint testindexobj [expr {[info commands testindexobj] ne {}}]
testConstraint testevalex [expr {[info commands testevalex] ne {}}]
| | > > | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
proc makeShared {s} {uplevel 1 [list lappend copy $s]; return $s}
# Some tests require the testobj command
testConstraint testobj [expr {[info commands testobj] ne {}}]
testConstraint testindexobj [expr {[info commands testindexobj] ne {}}]
testConstraint testevalex [expr {[info commands testevalex] ne {}}]
testConstraint utf32 [expr {[string length \U010000] == 1}]
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint utf32 [expr {[testConstraint fullutf]
&& [string length [format %c 0x10000]] == 1}]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
proc getbytes {} {
set lines [split [memory info] \n]
return [lindex $lines 3 3]
|
| ︙ | ︙ | |||
362 363 364 365 366 367 368 |
test string-3.41.$noComp {string equal, binary neq} {
run {string equal [binary format a100a 0 1] [binary format a100a 0 0]}
} 0
test string-3.42.$noComp {string equal, binary neq inequal length} {
run {string equal [binary format a20a 0 1] [binary format a100a 0 0]}
} 0
| < | 364 365 366 367 368 369 370 371 372 373 374 375 376 377 |
test string-3.41.$noComp {string equal, binary neq} {
run {string equal [binary format a100a 0 1] [binary format a100a 0 0]}
} 0
test string-3.42.$noComp {string equal, binary neq inequal length} {
run {string equal [binary format a20a 0 1] [binary format a100a 0 0]}
} 0
test string-4.1.$noComp {string first, not enough args} {
list [catch {run {string first a}} msg] $msg
} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}}
test string-4.2.$noComp {string first, bad args} {
list [catch {run {string first a b c}} msg] $msg
} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}}
test string-4.3.$noComp {string first, too many args} {
|
| ︙ | ︙ | |||
421 422 423 424 425 426 427 |
regexp ll $s m
# Representation checks are canaries
run {list [representationpoke $s] [representationpoke $m] \
[string first $m $s]}
} -result {{string 1} {string 0} 2}
test string-4.17.$noComp {string first, corner case} -body {
run {string first a aaa 4294967295}
| | | | | | | | 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 |
regexp ll $s m
# Representation checks are canaries
run {list [representationpoke $s] [representationpoke $m] \
[string first $m $s]}
} -result {{string 1} {string 0} 2}
test string-4.17.$noComp {string first, corner case} -body {
run {string first a aaa 4294967295}
} -result -1
test string-4.18.$noComp {string first, corner case} -body {
run {string first a aaa -1}
} -result 0
test string-4.19.$noComp {string first, corner case} -body {
run {string first a aaa end-5}
} -result 0
test string-4.20.$noComp {string last, corner case} -body {
run {string last a aaa 4294967295}
} -result 2
test string-4.21.$noComp {string last, corner case} -body {
run {string last a aaa -1}
} -result -1
test string-4.22.$noComp {string last, corner case} {
run {string last a aaa end-5}
} -1
test string-5.1.$noComp {string index} {
list [catch {run {string index}} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
test string-5.2.$noComp {string index} {
list [catch {run {string index a b c}} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
|
| ︙ | ︙ | |||
497 498 499 500 501 502 503 |
} 0
test string-5.17.$noComp {string index, bad integer} -body {
list [catch {run {string index "abc" 0o8}} msg] $msg
} -match glob -result {1 {*}}
test string-5.18.$noComp {string index, bad integer} -body {
list [catch {run {string index "abc" end-0o0289}} msg] $msg
} -match glob -result {1 {*}}
| | | | | 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 |
} 0
test string-5.17.$noComp {string index, bad integer} -body {
list [catch {run {string index "abc" 0o8}} msg] $msg
} -match glob -result {1 {*}}
test string-5.18.$noComp {string index, bad integer} -body {
list [catch {run {string index "abc" end-0o0289}} msg] $msg
} -match glob -result {1 {*}}
test string-5.19.$noComp {string index, bytearray object out of bounds} {
run {string index [binary format I* {0x50515253 0x52}] -1}
} {}
test string-5.20.$noComp {string index, bytearray object out of bounds} -body {
run {string index [binary format I* {0x50515253 0x52}] 20}
} -result {}
test string-5.21.$noComp {string index, surrogates, bug [11ae2be95dac9417]} -constraints utf32 -body {
run {list [string index a\U100000b 1] [string index a\U100000b 2] [string index a\U100000b 3]}
} -result [list \U100000 b {}]
test string-5.22.$noComp {string index} -constraints testbytestring -body {
run {list [scan [string index [testbytestring \xFF] 0] %c var] $var}
} -result {1 255}
|
| ︙ | ︙ | |||
982 983 984 985 986 987 988 989 990 991 992 993 994 995 |
} 0
test string-6.137.$noComp {string is unicode, noncharacter} {
run {string is unicode \uFDD0}
} 0
test string-6.138.$noComp {string is unicode, noncharacter} {
run {string is unicode \uFDEF}
} 0
test string-7.1.$noComp {string last, not enough args} {
list [catch {run {string last a}} msg] $msg
} {1 {wrong # args: should be "string last needleString haystackString ?lastIndex?"}}
test string-7.2.$noComp {string last, bad args} {
list [catch {run {string last a b c}} msg] $msg
| > > > > > > | 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 |
} 0
test string-6.137.$noComp {string is unicode, noncharacter} {
run {string is unicode \uFDD0}
} 0
test string-6.138.$noComp {string is unicode, noncharacter} {
run {string is unicode \uFDEF}
} 0
test string-6.139.$noComp {string is integer, bug [76ad7aeba3]} {
run {string is integer 18446744073709551615}
} 1
test string-6.140.$noComp {string is integer, bug [76ad7aeba3]} {
run {string is integer -18446744073709551615}
} 1
test string-7.1.$noComp {string last, not enough args} {
list [catch {run {string last a}} msg] $msg
} {1 {wrong # args: should be "string last needleString haystackString ?lastIndex?"}}
test string-7.2.$noComp {string last, bad args} {
list [catch {run {string last a b c}} msg] $msg
|
| ︙ | ︙ | |||
1068 1069 1070 1071 1072 1073 1074 |
list [catch {run {string map {a b} abba oops}} msg] $msg
} {1 {bad option "a b": must be -nocase}}
test string-10.3.$noComp {string map, too many args} {
list [catch {run {string map -nocase {a b} str1 str2}} msg] $msg
} {1 {wrong # args: should be "string map ?-nocase? charMap string"}}
test string-10.4.$noComp {string map} {
run {string map {a b} abba}
| | | | | | | | | 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 |
list [catch {run {string map {a b} abba oops}} msg] $msg
} {1 {bad option "a b": must be -nocase}}
test string-10.3.$noComp {string map, too many args} {
list [catch {run {string map -nocase {a b} str1 str2}} msg] $msg
} {1 {wrong # args: should be "string map ?-nocase? charMap string"}}
test string-10.4.$noComp {string map} {
run {string map {a b} abba}
} bbbb
test string-10.5.$noComp {string map} {
run {string map {a b} a}
} b
test string-10.6.$noComp {string map -nocase} {
run {string map -nocase {a b} Abba}
} bbbb
test string-10.7.$noComp {string map} {
run {string map {abc 321 ab * a A} aabcabaababcab}
} {A321*A*321*}
test string-10.8.$noComp {string map -nocase} {
run {string map -nocase {aBc 321 Ab * a A} aabcabaababcab}
} {A321*A*321*}
test string-10.9.$noComp {string map -nocase} {
run {string map -no {abc 321 Ab * a A} aAbCaBaAbAbcAb}
} {A321*A*321*}
test string-10.10.$noComp {string map} {
list [catch {run {string map {a b c} abba}} msg] $msg
} {1 {char map list unbalanced}}
test string-10.11.$noComp {string map, nulls} {
run {string map {\x00 NULL blah \x00nix} {qwerty}}
} qwerty
test string-10.12.$noComp {string map, unicode} {
run {string map [list ü ue UE Ü] "aüueUE\x00EU"}
} aueueÜ\x00EU
test string-10.13.$noComp {string map, -nocase unicode} {
run {string map -nocase [list ü ue UE Ü] "aüueUE\x00EU"}
} aueÜÜ\x00EU
test string-10.14.$noComp {string map, -nocase null arguments} {
run {string map -nocase {{} abc} foo}
} foo
test string-10.15.$noComp {string map, one pair case} {
run {string map -nocase {abc 32} aAbCaBaAbAbcAb}
} a32aBaAb32Ab
test string-10.16.$noComp {string map, one pair case} {
run {string map -nocase {ab 4321} aAbCaBaAbAbcAb}
} a4321C4321a43214321c4321
test string-10.17.$noComp {string map, one pair case} {
run {string map {Ab 4321} aAbCaBaAbAbcAb}
} a4321CaBa43214321c4321
test string-10.18.$noComp {string map, empty argument} {
run {string map -nocase {{} abc} foo}
} foo
test string-10.19.$noComp {string map, empty arguments} {
run {string map -nocase {{} abc f bar {} def} foo}
} baroo
test string-10.20.$noComp {string map, dictionaries don't alter map ordering} {
|
| ︙ | ︙ | |||
1501 1502 1503 1504 1505 1506 1507 |
list $input_hex $rxBuffer_hex $rxCRC_hex
} {000341 000341 0341}
test string-12.22.$noComp {string range, shimmering binary/index} {
set s 0000000001
binary scan $s a* x
run {string range $s $s end}
} 000000001
| | | 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 |
list $input_hex $rxBuffer_hex $rxCRC_hex
} {000341 000341 0341}
test string-12.22.$noComp {string range, shimmering binary/index} {
set s 0000000001
binary scan $s a* x
run {string range $s $s end}
} 000000001
test string-12.23.$noComp {string range, surrogates, bug [11ae2be95dac9417]} utf32 {
run {list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3]}
} [list \U100000 b {}]
test string-12.24.$noComp {bignum index arithmetic} -setup {
proc demo {i j} {string range fubar $i $j}
} -cleanup {
rename demo {}
} -body {
|
| ︙ | ︙ | |||
1579 1580 1581 1582 1583 1584 1585 |
test string-14.4.$noComp {string replace} {
} {}
test string-14.5.$noComp {string replace} {
run {string replace abcdefghijklmnop 2 14}
} {abp}
test string-14.6.$noComp {string replace} -body {
run {string replace abcdefghijklmnop 7 1000}
| | | | | | | | 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 |
test string-14.4.$noComp {string replace} {
} {}
test string-14.5.$noComp {string replace} {
run {string replace abcdefghijklmnop 2 14}
} {abp}
test string-14.6.$noComp {string replace} -body {
run {string replace abcdefghijklmnop 7 1000}
} -result abcdefg
test string-14.7.$noComp {string replace} {
run {string replace abcdefghijklmnop 10 end}
} abcdefghij
test string-14.8.$noComp {string replace} {
run {string replace abcdefghijklmnop 10 9}
} abcdefghijklmnop
test string-14.9.$noComp {string replace} {
run {string replace abcdefghijklmnop -3 2}
} defghijklmnop
test string-14.10.$noComp {string replace} {
run {string replace abcdefghijklmnop -3 -2}
} abcdefghijklmnop
test string-14.11.$noComp {string replace} -body {
run {string replace abcdefghijklmnop 1000 1010}
} -result abcdefghijklmnop
test string-14.12.$noComp {string replace} {
run {string replace abcdefghijklmnop -100 end}
} {}
test string-14.13.$noComp {string replace} {
list [catch {run {string replace abc abc 1}} msg] $msg
} {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}}
test string-14.14.$noComp {string replace} {
|
| ︙ | ︙ | |||
1771 1772 1773 1774 1775 1776 1777 |
} "Abcabc\xE7\xE7"
test string-17.7.$noComp {string totitle, unicode} {
run {string totitle \u01F3BCabc\xC7\xE7}
} "\u01F2bcabc\xE7\xE7"
test string-17.8.$noComp {string totitle, compiled} {
lindex [run {string totitle [list aa bb [list cc]]}] 0
} Aa
| | | 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 |
} "Abcabc\xE7\xE7"
test string-17.7.$noComp {string totitle, unicode} {
run {string totitle \u01F3BCabc\xC7\xE7}
} "\u01F2bcabc\xE7\xE7"
test string-17.8.$noComp {string totitle, compiled} {
lindex [run {string totitle [list aa bb [list cc]]}] 0
} Aa
test string-17.9.$noComp {string totitle, surrogates, bug [11ae2be95dac9417]} utf32 {
run {list [string totitle a\U118c0c 1 1] [string totitle a\U118c0c 2 2] \
[string totitle a\U118c0c 3 3]}
} [list a\U118a0c a\U118c0C a\U118c0c]
test string-18.1.$noComp {string trim} {
list [catch {run {string trim}} msg] $msg
} {1 {wrong # args: should be "string trim string ?chars?"}}
|
| ︙ | ︙ | |||
1841 1842 1843 1844 1845 1846 1847 |
} {}
test string-20.5.$noComp {string trimright} {
run {string trimright ""}
} {}
test string-20.6.$noComp {string trimright, unicode default} {
run {string trimright ABC\u1361\x85\x00\xA0\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000}
} ABC\u1361
| | | | 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 |
} {}
test string-20.5.$noComp {string trimright} {
run {string trimright ""}
} {}
test string-20.6.$noComp {string trimright, unicode default} {
run {string trimright ABC\u1361\x85\x00\xA0\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000}
} ABC\u1361
test string-20.7.$noComp {string trim on not valid utf-8 sequence (consider NTS as continuation char), bug [c61818e4c9]} testbytestring {
set result {}
set a [testbytestring \xC0\x80\xA0]
set b foo$a
set m [list \x00 U \xA0 V [testbytestring \xA0] W]
lappend result [string map $m $b]
lappend result [string map $m [run {string trimright $b x}]]
lappend result [string map $m [run {string trimright $b \x00}]]
lappend result [string map $m [run {string trimleft $b fox}]]
lappend result [string map $m [run {string trimleft $b fo\x00}]]
lappend result [string map $m [run {string trim $b fox}]]
lappend result [string map $m [run {string trim $b fo\x00}]]
} [list {*}[lrepeat 3 fooUV] {*}[lrepeat 2 UV V]]
test string-20.8.$noComp {[c61818e4c9] [string trimright] fails when UtfPrev is ok} testbytestring {
set result {}
set a [testbytestring \xE8\xA0]
set b foo$a
set m [list \xE8 U \xA0 V [testbytestring \xE8] W [testbytestring \xA0] X]]
lappend result [string map $m $b]
lappend result [string map $m [run {string trimright $b x}]]
lappend result [string map $m [run {string trimright $b \xE8}]]
|
| ︙ | ︙ | |||
1915 1916 1917 1918 1919 1920 1921 |
} -result 3
test string-21.14.$noComp {string wordend, unicode} -body {
run {string wordend "\uC700\uC700 abc" 8}
} -result 6
test string-21.15.$noComp {string wordend, unicode} -body {
run {string wordend "\U1D7CA\U1D7CA abc" 0}
} -result 2
| | | 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 |
} -result 3
test string-21.14.$noComp {string wordend, unicode} -body {
run {string wordend "\uC700\uC700 abc" 8}
} -result 6
test string-21.15.$noComp {string wordend, unicode} -body {
run {string wordend "\U1D7CA\U1D7CA abc" 0}
} -result 2
test string-21.16.$noComp {string wordend, unicode} -constraints utf32 -body {
run {string wordend "\U1D7CA\U1D7CA abc" 10}
} -result 6
test string-21.17.$noComp {string trim, unicode} {
run {string trim "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD83D\uDE02}
} "Hello world!"
test string-21.18.$noComp {string trimleft, unicode} {
run {string trimleft "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD83D\uDE02}
|
| ︙ | ︙ | |||
1937 1938 1939 1940 1941 1942 1943 |
test string-21.21.$noComp {string trimleft, unicode} {
run {string trimleft "\uF602Hello world!\uF602" \uD83D\uDE02}
} "\uF602Hello world!\uF602"
test string-21.22.$noComp {string trimright, unicode} {
run {string trimright "\uF602Hello world!\uF602" \uD83D\uDE02}
} "\uF602Hello world!\uF602"
test string-21.23.$noComp {string trim, unicode} {
| | | | 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 |
test string-21.21.$noComp {string trimleft, unicode} {
run {string trimleft "\uF602Hello world!\uF602" \uD83D\uDE02}
} "\uF602Hello world!\uF602"
test string-21.22.$noComp {string trimright, unicode} {
run {string trimright "\uF602Hello world!\uF602" \uD83D\uDE02}
} "\uF602Hello world!\uF602"
test string-21.23.$noComp {string trim, unicode} {
run {string trim "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D}
} "\uD83D\uDE02Hello world!\uD83D\uDE02"
test string-21.24.$noComp {string trimleft, unicode} {
run {string trimleft "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D\uDE02}
} "\uD83D\uDE02Hello world!\uD83D\uDE02"
test string-21.25.$noComp {string trimright, unicode} {
run {string trimright "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D}
} "\uD83D\uDE02Hello world!\uD83D\uDE02"
test string-22.1.$noComp {string wordstart} -body {
list [catch {run {string word a}} msg] $msg
} -result {1 {unknown or ambiguous subcommand "word": must be cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-22.2.$noComp {string wordstart} -body {
list [catch {run {string wordstart a}} msg] $msg
|
| ︙ | ︙ | |||
1993 1994 1995 1996 1997 1998 1999 |
# See Bug c61818e4c9
set demo [testbytestring "abc def\xE0\xA9ghi"]
run {string index $demo [string wordstart $demo 10]}
} -result g
test string-22.15.$noComp {string wordstart, unicode} -body {
run {string wordstart "\U1D7CA\U1D7CA abc" 0}
} -result 0
| | | 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 |
# See Bug c61818e4c9
set demo [testbytestring "abc def\xE0\xA9ghi"]
run {string index $demo [string wordstart $demo 10]}
} -result g
test string-22.15.$noComp {string wordstart, unicode} -body {
run {string wordstart "\U1D7CA\U1D7CA abc" 0}
} -result 0
test string-22.16.$noComp {string wordstart, unicode} -constraints utf32 -body {
run {string wordstart "\U1D7CA\U1D7CA abc" 10}
} -result 3
test string-23.0.$noComp {string is boolean, Bug 1187123} testindexobj {
set x 5
catch {testindexobj $x foo bar soom}
run {string is boolean $x}
|
| ︙ | ︙ | |||
2107 2108 2109 2110 2111 2112 2113 |
binary scan [run {string reverse [binary format H* 010203]}] H* x
set x
} 030201
test string-24.15.$noComp {string reverse command - pure bytearray} {
binary scan [run {tcl::string::reverse [binary format H* 010203]}] H* x
set x
} 030201
| | | | | | | | | | 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 |
binary scan [run {string reverse [binary format H* 010203]}] H* x
set x
} 030201
test string-24.15.$noComp {string reverse command - pure bytearray} {
binary scan [run {tcl::string::reverse [binary format H* 010203]}] H* x
set x
} 030201
test string-24.16.$noComp {string reverse command - surrogates} utf32 {
run {string reverse \u0444bulb\uD83D\uDE02}
} \uDE02\uD83Dblub\u0444
test string-24.17.$noComp {string reverse command - surrogates} utf32 {
run {string reverse \uD83D\uDE02hello\uD83D\uDE02}
} \uDE02\uD83Dolleh\uDE02\uD83D
test string-24.18.$noComp {string reverse command - surrogates} utf32 {
set s \u0444bulb\uD83D\uDE02
# shim shimmery ...
string index $s 0
run {string reverse $s}
} \uDE02\uD83Dblub\u0444
test string-24.19.$noComp {string reverse command - surrogates} utf32 {
set s \uD83D\uDE02hello\uD83D\uDE02
# shim shimmery ...
string index $s 0
run {string reverse $s}
} \uDE02\uD83Dolleh\uDE02\uD83D
test string-25.1.$noComp {string is list} {
run {string is list {a b c}}
} 1
test string-25.2.$noComp {string is list} {
run {string is list "a \{b c"}
} 0
|
| ︙ | ︙ |
Changes to tests/stringObj.test.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 | ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] testConstraint testobj [llength [info commands testobj]] testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testdstring [llength [info commands testdstring]] | | | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testobj [llength [info commands testobj]]
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testdstring [llength [info commands testdstring]]
testConstraint utf32 [expr {[string length \U010000] == 1}]
test stringObj-1.1 {string type registration} testobj {
set t [testobj types]
set first [string first "string" $t]
set result [expr {$first >= 0}]
} 1
|
| ︙ | ︙ | |||
450 451 452 453 454 455 456 |
teststringobj set 1 foo
teststringobj appendself 1 2
} fooo
test stringObj-15.4 {Tcl_Append*ToObj: self appends} testobj {
teststringobj set 1 foo
teststringobj appendself 1 3
} foo
| | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 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 |
teststringobj set 1 foo
teststringobj appendself 1 2
} fooo
test stringObj-15.4 {Tcl_Append*ToObj: self appends} testobj {
teststringobj set 1 foo
teststringobj appendself 1 3
} foo
test stringObj-15.5 {Tcl_Append*ToObj: self appends} {testobj utf32} {
teststringobj set 1 foo
teststringobj appendself2 1 0
} foofoo
test stringObj-15.6 {Tcl_Append*ToObj: self appends} {testobj utf32} {
teststringobj set 1 foo
teststringobj appendself2 1 1
} foooo
test stringObj-15.7 {Tcl_Append*ToObj: self appends} {testobj utf32} {
teststringobj set 1 foo
teststringobj appendself2 1 2
} fooo
test stringObj-15.8 {Tcl_Append*ToObj: self appends} {testobj utf32} {
teststringobj set 1 foo
teststringobj appendself2 1 3
} foo
test stringObj-16.0 {Tcl_GetRange: normal case} testobj {
teststringobj set 1 abcde
teststringobj range 1 1 3
} bcd
test stringObj-16.1 {Tcl_GetRange: first > end} testobj {
teststringobj set 1 abcde
teststringobj range 1 10 5
} {}
test stringObj-16.2 {Tcl_GetRange: last > end} testobj {
teststringobj set 1 abcde
teststringobj range 1 3 13
} de
test stringObj-16.3 {Tcl_GetRange: first = TCL_INDEX_NONE} testobj {
teststringobj set 1 abcde
teststringobj range 1 -1 3
} abcd
test stringObj-16.4 {Tcl_GetRange: last = TCL_INDEX_NONE} testobj {
teststringobj set 1 abcde
teststringobj range 1 1 -1
} bcde
test stringObj-16.5 {Tcl_GetRange: first = last = TCL_INDEX_NONE} testobj {
teststringobj set 1 abcde
teststringobj range 1 -1 -1
} abcde
test stringObj-16.6 {Tcl_GetRange: first = UINT_MAX-1} testobj {
teststringobj set 1 abcde
teststringobj range 1 0xFFFFFFFE 3
} {}
test stringObj-16.7 {Tcl_GetRange: first = SIZE_MAX-1} testobj {
teststringobj set 1 abcde
teststringobj range 1 -2 3
} {}
test stringObj-16.8 {Tcl_GetRange: last = UINT_MAX-1} testobj {
teststringobj set 1 abcde
teststringobj range 1 1 0xFFFFFFFE
} bcde
test stringObj-16.9 {Tcl_GetRange: last = SIZE_MAX-1} testobj {
teststringobj set 1 abcde
teststringobj range 1 1 -2
} bcde
test stringObj-16.10 {Tcl_GetRange: first = last = UINT_MAX-1} testobj {
teststringobj set 1 abcde
teststringobj range 1 0xFFFFFFFE 0xFFFFFFFE
} {}
test stringObj-16.11 {Tcl_GetRange: first = last = SIZE_MAX-1} testobj {
teststringobj set 1 abcde
teststringobj range 1 -2 -2
} {}
if {[testConstraint testobj]} {
testobj freeallvars
}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/utf.test.
| ︙ | ︙ | |||
74 75 76 77 78 79 80 |
} 1
test utf-1.11 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring {
expr {[format %c 0xDC42] eq [testbytestring \xED\xB1\x82]}
} 1
test utf-1.12 {Tcl_UniCharToUtf: 4 byte sequence, high/low surrogate} {pairsTo4bytes testbytestring} {
expr {"\uD842\uDC42" eq [testbytestring \xF0\xA0\xA1\x82]}
} 1
| | | | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 |
} 1
test utf-1.11 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring {
expr {[format %c 0xDC42] eq [testbytestring \xED\xB1\x82]}
} 1
test utf-1.12 {Tcl_UniCharToUtf: 4 byte sequence, high/low surrogate} {pairsTo4bytes testbytestring} {
expr {"\uD842\uDC42" eq [testbytestring \xF0\xA0\xA1\x82]}
} 1
test utf-1.13.0 {Tcl_UniCharToUtf: Invalid surrogate} Uesc {
expr {"\UD842" eq "\uD842"}
} 1
test utf-1.13.1 {Tcl_UniCharToUtf: Invalid surrogate} {fullutf testbytestring} {
expr {"\UD842" eq [testbytestring \xED\xA1\x82]}
} 1
test utf-1.14 {Tcl_UniCharToUtf: surrogate pairs from concat} {
set lo \uDE02
return \uD83D$lo
} \uD83D\uDE02
test utf-1.15 {Tcl_UniCharToUtf: surrogate pairs from concat} {
set hi \uD83D
|
| ︙ | ︙ | |||
1110 1111 1112 1113 1114 1115 1116 |
} ᲐᲐ
test utf-11.6 {Tcl_UtfToUpper beyond U+FFFF} fullutf {
string toupper 𐐨
} 𐐀
test utf-11.7 {Tcl_UtfToUpper beyond U+FFFF} fullutf {
string toupper 𐐨
} 𐐀
| | | | 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 |
} ᲐᲐ
test utf-11.6 {Tcl_UtfToUpper beyond U+FFFF} fullutf {
string toupper 𐐨
} 𐐀
test utf-11.7 {Tcl_UtfToUpper beyond U+FFFF} fullutf {
string toupper 𐐨
} 𐐀
test utf-11.8 {Tcl_UtfToUpper low/high surrogate)} utf32 {
string toupper \uDC24\uD824
} \uDC24\uD824
test utf-12.1 {Tcl_UtfToLower} {
string tolower {}
} {}
test utf-12.2 {Tcl_UtfToLower} {
string tolower ABC
} abc
test utf-12.3 {Tcl_UtfToLower} {
string tolower ÃGH
} ãgh
test utf-12.4 {Tcl_UtfToLower} {
string tolower ǢGH
} ǣgh
test utf-12.5 {Tcl_UtfToLower Georgian (new in Unicode 11)} {
string tolower აᲐ
} აა
test utf-12.6 {Tcl_UtfToLower low/high surrogate)} utf32 {
string tolower \uDC24\uD824
} \uDC24\uD824
test utf-12.7 {Tcl_UtfToLower beyond U+FFFF} fullutf {
string tolower 𐐀
} 𐐨
test utf-12.8 {Tcl_UtfToLower beyond U+FFFF} fullutf {
string tolower 𐐀
|
| ︙ | ︙ | |||
1157 1158 1159 1160 1161 1162 1163 |
} Dzab
test utf-13.5 {Tcl_UtfToTitle Georgian (new in Unicode 11)} {
string totitle აᲐ
} აᲐ
test utf-13.6 {Tcl_UtfToTitle Georgian (new in Unicode 11)} {
string totitle Აა
} Აა
| | | 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 |
} Dzab
test utf-13.5 {Tcl_UtfToTitle Georgian (new in Unicode 11)} {
string totitle აᲐ
} აᲐ
test utf-13.6 {Tcl_UtfToTitle Georgian (new in Unicode 11)} {
string totitle Აა
} Აა
test utf-13.7 {Tcl_UtfToTitle low/high surrogate)} utf32 {
string totitle \uDC24\uD824
} \uDC24\uD824
test utf-13.8 {Tcl_UtfToTitle beyond U+FFFF} fullutf {
string totitle 𐐨𐐀
} 𐐀𐐨
test utf-13.9 {Tcl_UtfToTitle beyond U+FFFF} fullutf {
string totitle 𐐨𐐀
|
| ︙ | ︙ |
Changes to tests/winConsole.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
| > > | > > | > > > > > > > > > | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > | 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 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 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 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 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 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 219 220 221 222 223 224 225 226 227 228 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 364 365 366 367 368 369 370 371 372 373 374 375 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
catch {package require twapi} ;# Only to bring window to foreground. Not critical
::tcltest::ConstraintInitializer haveThread { expr {![catch {package require Thread}]} }
# Prompt user for a yes/no response
proc yesno {question {default "Y"}} {
set answer ""
# Make sure we are seen but catch because ui and console
# packages may not be available
catch {twapi::set_foreground_window [twapi::get_console_window]}
while {![string is boolean -strict $answer]} {
puts -nonewline stdout "$question Type Y/N followed by Enter \[$default\] : "
flush stdout
set answer [string trim [gets stdin]]
if {$answer eq ""} {
set answer $default
}
}
return [expr {!! $answer}]
}
proc prompt {prompt} {
# Make sure we are seen but catch because twapi ui and console
# packages may not be available
catch {twapi::set_foreground_window [twapi::get_console_window]}
puts -nonewline stdout "$prompt"
flush stdout
}
# Input tests
test console-input-1.0 {Console blocking gets} -constraints {win interactive} -body {
prompt "Type \"xyz\" and hit Enter: "
gets stdin
} -result xyz
test console-input-1.1 {Console file channel: non-blocking gets} -constraints {
win interactive
} -setup {
unset -nocomplain result
unset -nocomplain result2
} -body {
set oldmode [fconfigure stdin]
prompt "Type \"abc\" and hit Enter: "
fileevent stdin readable {
if {[gets stdin line] >= 0} {
lappend result2 $line
if {[llength $result2] > 1} {
set result $result2
} else {
prompt "Type \"def\" and hit Enter: "
}
} elseif {[eof stdin]} {
set result "gets failed"
}
}
fconfigure stdin -blocking 0 -buffering line
vwait result
#cleanup the fileevent
fileevent stdin readable {}
fconfigure stdin {*}$oldmode
set result
} -result {abc def}
test console-input-1.1.1 {Bug baa51423c28a: Console file channel: fileevent with blocking gets} -constraints {
win interactive
} -setup {
unset -nocomplain result
unset -nocomplain result2
} -body {
prompt "Type \"abc\" and hit Enter: "
fileevent stdin readable {
if {[gets stdin line] >= 0} {
lappend result2 $line
if {[llength $result2] > 1} {
set result $result2
} else {
prompt "Type \"def\" and hit Enter: "
}
} elseif {[eof stdin]} {
set result "gets failed"
}
}
vwait result
#cleanup the fileevent
fileevent stdin readable {}
set result
} -result {abc def}
test console-input-2.0 {Console blocking read} -constraints {win interactive} -setup {
set oldmode [fconfigure stdin]
fconfigure stdin -inputmode raw
} -cleanup {
fconfigure stdin {*}$oldmode
} -body {
prompt "Type the key \"a\". Do NOT hit Enter. You will NOT see characters echoed."
set c [read stdin 1]
puts ""
set c
} -result a
test console-input-2.1 {Console file channel: non-blocking read} -constraints {
win interactive
} -setup {
set oldmode [fconfigure stdin]
} -cleanup {
fconfigure stdin {*}$oldmode
puts ""; # Because CRLF also would not have been echoed
} -body {
set input ""
fconfigure stdin -blocking 0 -buffering line -inputmode raw
prompt "Type \"abc\". Do NOT hit Enter. You will NOT see characters echoed."
fileevent stdin readable {
set c [read stdin 1]
if {$c eq ""} {
if {[eof stdin]} {
set result "read eof"
}
} else {
append input $c
if {[string length $input] == 3} {
set result $input
}
}
}
set result {}
vwait result
fileevent stdin readable {}
set result
} -result abc
# Output tests
test console-output-1.0 {Console blocking puts stdout} -constraints {win interactive} -body {
puts stdout "123"
yesno "Did you see the string \"123\"?"
} -result 1
test console-output-1.1 {Console non-blocking puts stdout} -constraints {
win interactive
} -setup {
set oldmode [fconfigure stdout]
dict unset oldmode -winsize
} -cleanup {
fconfigure stdout {*}$oldmode
} -body {
fconfigure stdout -blocking 0 -buffering line
set count 0
fileevent stdout writable {
if {[incr count] < 4} {
puts "$count"
} else {
fileevent stdout writable {}
set done 1
}
}
vwait done
yesno "Did you see 1, 2, 3 printed on consecutive lines?"
} -result 1
test console-output-2.0 {Console blocking puts stderr} -constraints {win interactive} -body {
puts stderr "456"
yesno "Did you see the string \"456\"?"
} -result 1
# fconfigure get tests
## fconfigure get stdin
test console-fconfigure-get-1.0 {
Console get stdin configuration
} -constraints {win interactive} -body {
lsort [dict keys [fconfigure stdin]]
} -result {-blocking -buffering -buffersize -encoding -eofchar -inputmode -translation}
set testnum 0
foreach {opt result} {
-blocking 1
-buffering line
-buffersize 4096
-encoding utf-16
-inputmode normal
-translation auto
} {
test console-fconfigure-get-1.[incr testnum] "Console get stdin option $opt" \
-constraints {win interactive} -body {
fconfigure stdin $opt
} -result $result
}
test console-fconfigure-get-1.[incr testnum] {
Console get stdin option -eofchar
} -constraints {win interactive} -body {
fconfigure stdin -eofchar
} -result \x1a
test console-fconfigure-get-1.[incr testnum] {
fconfigure -winsize
} -constraints {win interactive} -body {
fconfigure stdin -winsize
} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -inputmode} -returnCodes error
## fconfigure get stdout/stderr
foreach chan {stdout stderr} major {2 3} {
test console-fconfigure-get-$major.0 "Console get $chan configuration" -constraints {
win interactive
} -body {
lsort [dict keys [fconfigure $chan]]
} -result {-blocking -buffering -buffersize -encoding -eofchar -translation -winsize}
set testnum 0
foreach {opt result} {
-blocking 1
-buffersize 4096
-encoding utf-16
-translation crlf
} {
test console-fconfigure-get-$major.[incr testnum] "Console get $chan option $opt" \
-constraints {win interactive} -body {
fconfigure $chan $opt
} -result $result
}
test console-fconfigure-get-$major.[incr testnum] "Console get $chan option -winsize" \
-constraints {win interactive} -body {
fconfigure $chan -winsize
} -result {\d+ \d+} -match regexp
test console-fconfigure-get-$major.[incr testnum] "Console get $chan option -buffering" \
-constraints {win interactive} -body {
fconfigure $chan -buffering
} -result [expr {$chan eq "stdout" ? "line" : "none"}]
test console-fconfigure-get-$major.[incr testnum] {
fconfigure -inputmode
} -constraints {win interactive} -body {
fconfigure $chan -inputmode
} -result {bad option "-inputmode": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -winsize} -returnCodes error
}
## fconfigure set stdin
test console-fconfigure-set-1.0 {
fconfigure -inputmode password
} -constraints {win interactive} -body {
set result {}
prompt "Type \"pass\" and hit Enter. You should NOT see characters echoed: "
fconfigure stdin -inputmode password
lappend result [gets stdin]
lappend result [fconfigure stdin -inputmode]
fconfigure stdin -inputmode normal
lappend result [yesno "\nWere the characters echoed?"]
prompt "Type \"norm\" and hit Enter. You should see characters echoed: "
lappend result [gets stdin]
lappend result [fconfigure stdin -inputmode]
lappend result [yesno "Were the characters echoed?"]
set result
} -result [list pass password 0 norm normal 1]
test console-fconfigure-set-1.1 {
fconfigure -inputmode raw
} -constraints {win interactive} -body {
set result {}
prompt "Type the keys \"a\", Ctrl-H, \"b\". Do NOT hit Enter. You should NOT see characters echoed: "
fconfigure stdin -inputmode raw
lappend result [read stdin 3]
lappend result [fconfigure stdin -inputmode]
fconfigure stdin -inputmode normal
lappend result [yesno "\nWere the characters echoed?"]
prompt "Type the keys \"c\", Ctrl-H, \"d\" and hit Enter. You should see characters echoed: "
lappend result [gets stdin]
lappend result [fconfigure stdin -inputmode]
lappend result [yesno "Were the characters echoed (c replaced by d)?"]
set result
} -result [list a\x08b raw 0 d normal 1]
test console-fconfigure-set-1.2 {
fconfigure -inputmode reset
} -constraints {win interactive} -body {
set result {}
prompt "Type \"pass\" and hit Enter. You should NOT see characters echoed: "
fconfigure stdin -inputmode password
lappend result [gets stdin]
lappend result [fconfigure stdin -inputmode]
fconfigure stdin -inputmode reset
lappend result [yesno "\nWere the characters echoed?"]
prompt "Type \"reset\" and hit Enter. You should see characters echoed: "
lappend result [gets stdin]
lappend result [fconfigure stdin -inputmode]
lappend result [yesno "Were the characters echoed?"]
set result
} -result [list pass password 0 reset normal 1]
test console-fconfigure-set-1.3 {
fconfigure stdin -winsize
} -constraints {win interactive} -body {
fconfigure stdin -winsize {10 30}
} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -inputmode} -returnCodes error
## fconfigure set stdout,stderr
test console-fconfigure-set-2.0 {
fconfigure stdout -winsize
} -constraints {win interactive} -body {
fconfigure stdout -winsize {10 30}
} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation} -returnCodes error
test console-fconfigure-set-3.0 {
fconfigure stderr -winsize
} -constraints {win interactive} -body {
fconfigure stderr -winsize {10 30}
} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation} -returnCodes error
# Multiple threads
test console-thread-input-1.0 {Get input in thread} -constraints {
win interactive haveThread
} -setup {
set tid [thread::create]
} -cleanup {
thread::release $tid
} -body {
prompt "Type \"xyz\" and hit Enter: "
thread::send $tid {gets stdin}
} -result xyz
test console-thread-output-1.0 {Output from thread} -constraints {
win interactive haveThread
} -setup {
set tid [thread::create]
} -cleanup {
thread::release $tid
} -body {
thread::send $tid {puts [thread::id]}
yesno "Did you see $tid printed?"
} -result 1
::tcltest::cleanupTests
return
|
Changes to tests/winFile.test.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 |
if {[testConstraint testvolumetype]} {
testConstraint notNTFS [expr {[testvolumetype] eq "NTFS"}]
}
testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}]
test winFile-1.1 {TclpGetUserHome} -constraints {win} -body {
glob ~nosuchuser
| | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
if {[testConstraint testvolumetype]} {
testConstraint notNTFS [expr {[testvolumetype] eq "NTFS"}]
}
testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}]
test winFile-1.1 {TclpGetUserHome} -constraints {win} -body {
glob ~nosuchuser
} -returnCodes error -result {no files matched glob pattern "~nosuchuser"}
test winFile-1.2 {TclpGetUserHome} -constraints {win nonPortable} -body {
# The administrator account should always exist.
glob ~administrator
} -match glob -result *
test winFile-1.4 {TclpGetUserHome} {win nonPortable} {
catch {glob ~stanton@workgroup}
} {0}
|
| ︙ | ︙ |
Changes to tools/tcltk-man2html.tcl.
| ︙ | ︙ | |||
39 40 41 42 43 44 45 |
if {$name eq ""} {
set name [string toupper [file root [file tail $tclh]]]
}
# backslash isn't required in front of quote, but it keeps syntax
# highlighting straight in some editors
if {[regexp -lineanchor \
[string map [list @name@ $name] \
| | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
if {$name eq ""} {
set name [string toupper [file root [file tail $tclh]]]
}
# backslash isn't required in front of quote, but it keeps syntax
# highlighting straight in some editors
if {[regexp -lineanchor \
[string map [list @name@ $name] \
{^#\s*define\s+@name@_VERSION\s+\"([^.])+\.([^.\"]+)}] \
$data -> major minor]} {
return [list $major $minor]
}
}
}
proc findversion {top name useversion} {
# Default search version is a glob pattern, switch it for string match:
|
| ︙ | ︙ |
Changes to tools/tsdPerf.c.
1 2 3 4 5 6 7 8 9 10 11 12 |
#include <tcl.h>
extern DLLEXPORT Tcl_LibraryInitProc Tsdperf_Init;
static Tcl_ThreadDataKey key;
typedef struct {
Tcl_WideInt value;
} TsdPerf;
static int
| | | | 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 |
#include <tcl.h>
extern DLLEXPORT Tcl_LibraryInitProc Tsdperf_Init;
static Tcl_ThreadDataKey key;
typedef struct {
Tcl_WideInt value;
} TsdPerf;
static int
tsdPerfSetObjCmd(void *cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) {
TsdPerf *perf = Tcl_GetThreadData(&key, sizeof(TsdPerf));
Tcl_WideInt i;
if (2 != objc) {
Tcl_WrongNumArgs(interp, 1, objv, "value");
return TCL_ERROR;
}
if (TCL_OK != Tcl_GetWideIntFromObj(interp, objv[1], &i)) {
return TCL_ERROR;
}
perf->value = i;
return TCL_OK;
}
static int
tsdPerfGetObjCmd(void *cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) {
TsdPerf *perf = Tcl_GetThreadData(&key, sizeof(TsdPerf));
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(perf->value));
return TCL_OK;
}
|
| ︙ | ︙ |
Changes to unix/Makefile.in.
| ︙ | ︙ | |||
172 173 174 175 176 177 178 | # The symbols below provide support for dynamic loading and shared libraries. # See configure.ac for a description of what the symbols mean. The values of # the symbols are normally set by the configure script. You shouldn't normally # need to modify any of these definitions by hand. STLIB_LD = @STLIB_LD@ SHLIB_LD = @SHLIB_LD@ | | | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 | # The symbols below provide support for dynamic loading and shared libraries. # See configure.ac for a description of what the symbols mean. The values of # the symbols are normally set by the configure script. You shouldn't normally # need to modify any of these definitions by hand. STLIB_LD = @STLIB_LD@ SHLIB_LD = @SHLIB_LD@ SHLIB_CFLAGS = @SHLIB_CFLAGS@ SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ SHLIB_LD_FLAGS = @SHLIB_LD_FLAGS@ TCL_SHLIB_LD_EXTRAS = @TCL_SHLIB_LD_EXTRAS@ SHLIB_SUFFIX = @SHLIB_SUFFIX@ DLTEST_TARGETS = dltest.marker |
| ︙ | ︙ | |||
274 275 276 277 278 279 280 |
#--------------------------------------------------------------------------
# The information below should be usable as is. The configure script won't
# modify it and you shouldn't need to modify it either.
#--------------------------------------------------------------------------
STUB_CC_SWITCHES = -I"${BUILD_DIR}" -I${UNIX_DIR} -I${GENERIC_DIR} -I${TOMMATH_DIR} \
${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
| | | | | | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 |
#--------------------------------------------------------------------------
# The information below should be usable as is. The configure script won't
# modify it and you shouldn't need to modify it either.
#--------------------------------------------------------------------------
STUB_CC_SWITCHES = -I"${BUILD_DIR}" -I${UNIX_DIR} -I${GENERIC_DIR} -I${TOMMATH_DIR} \
${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
${AC_FLAGS} ${ENV_FLAGS} ${EXTRA_CFLAGS} @EXTRA_CC_SWITCHES@ \
${NO_DEPRECATED_FLAGS} -DMP_FIXED_CUTOFFS -DMP_NO_STDINT
CC_SWITCHES = $(STUB_CC_SWITCHES) -DBUILD_tcl
APP_CC_SWITCHES = $(STUB_CC_SWITCHES) @EXTRA_APP_CC_SWITCHES@
LIBS = @TCL_LIBS@
DEPEND_SWITCHES = ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \
${AC_FLAGS} ${EXTRA_CFLAGS} @EXTRA_CC_SWITCHES@
TCLSH_OBJS = tclAppInit.o
|
| ︙ | ︙ | |||
1039 1040 1041 1042 1043 1044 1045 | done; @echo "Installing package cookiejar 0.2 files to $(SCRIPT_INSTALL_DIR)/cookiejar0.2/" @for i in $(TOP_DIR)/library/cookiejar/*.tcl \ $(TOP_DIR)/library/cookiejar/*.gz; \ do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \ done | | | | | | 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 | done; @echo "Installing package cookiejar 0.2 files to $(SCRIPT_INSTALL_DIR)/cookiejar0.2/" @for i in $(TOP_DIR)/library/cookiejar/*.tcl \ $(TOP_DIR)/library/cookiejar/*.gz; \ do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \ done @echo "Installing package http 2.10a4 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl \ "$(MODULE_INSTALL_DIR)/9.0/http-2.10a4.tm" @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.7.1 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \ "$(MODULE_INSTALL_DIR)/9.0/msgcat-1.7.1.tm" @echo "Installing package tcltest 2.5.5 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \ "$(MODULE_INSTALL_DIR)/9.0/tcltest-2.5.5.tm" @echo "Installing package platform 1.0.18 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \ "$(MODULE_INSTALL_DIR)/9.0/platform-1.0.18.tm" @echo "Installing package platform::shell 1.1.4 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl \ "$(MODULE_INSTALL_DIR)/9.0/platform/shell-1.1.4.tm" @echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/" |
| ︙ | ︙ |
Changes to unix/dltest/pkga.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #undef STATIC_BUILD #include "tcl.h" | < < < < < < < < < | | 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 40 41 42 43 |
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#undef STATIC_BUILD
#include "tcl.h"
/*
*----------------------------------------------------------------------
*
* Pkga_EqObjCmd --
*
* This procedure is invoked to process the "pkga_eq" Tcl command. It
* expects two arguments and returns 1 if they are the same, 0 if they
* are different.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
Pkga_EqObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int result;
const char *str1, *str2;
int len1, len2;
|
| ︙ | ︙ | |||
83 84 85 86 87 88 89 | * See the user documentation. * *---------------------------------------------------------------------- */ static int Pkga_QuoteObjCmd( | | | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
Pkga_QuoteObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
(void)dummy;
if (objc != 2) {
|
| ︙ | ︙ |
Changes to unix/dltest/pkgb.c.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #undef STATIC_BUILD #include "tcl.h" | < < < < < < < < < < < < < < < | | 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 40 41 42 43 |
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#undef STATIC_BUILD
#include "tcl.h"
/*
*----------------------------------------------------------------------
*
* Pkgb_SubObjCmd --
*
* This procedure is invoked to process the "pkgb_sub" Tcl command. It
* expects two arguments and returns their difference.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
Pkgb_SubObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int first, second;
(void)dummy;
|
| ︙ | ︙ | |||
86 87 88 89 90 91 92 | * See the user documentation. * *---------------------------------------------------------------------- */ static int Pkgb_UnsafeObjCmd( | | | < | > | | > > | | | < < > | < | 71 72 73 74 75 76 77 78 79 80 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 106 107 108 109 110 111 112 113 114 115 116 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
Pkgb_UnsafeObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
(void)dummy;
(void)objc;
(void)objv;
return Tcl_EvalEx(interp, "list unsafe command invoked", -1, TCL_EVAL_GLOBAL);
}
static int
Pkgb_DemoObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_WideInt numChars;
int result;
(void)dummy;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "arg1 arg2 num");
return TCL_ERROR;
}
if (Tcl_GetWideIntFromObj(interp, objv[3], &numChars) != TCL_OK) {
return TCL_ERROR;
}
result = Tcl_UtfNcmp(Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), numChars);
Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkgb_Init --
|
| ︙ | ︙ |
Changes to unix/dltest/pkgc.c.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #undef STATIC_BUILD #include "tcl.h" | < < < < < < < < < | | 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 40 41 42 43 |
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#undef STATIC_BUILD
#include "tcl.h"
/*
*----------------------------------------------------------------------
*
* Pkgc_SubObjCmd --
*
* This procedure is invoked to process the "pkgc_sub" Tcl command. It
* expects two arguments and returns their difference.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
Pkgc_SubObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int first, second;
(void)dummy;
|
| ︙ | ︙ | |||
77 78 79 80 81 82 83 | * See the user documentation. * *---------------------------------------------------------------------- */ static int Pkgc_UnsafeObjCmd( | | | 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
Pkgc_UnsafeObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
(void)dummy;
(void)objc;
(void)objv;
|
| ︙ | ︙ |
Changes to unix/dltest/pkgd.c.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #undef STATIC_BUILD #include "tcl.h" | < < < < < < < < < | | 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 40 41 42 43 |
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#undef STATIC_BUILD
#include "tcl.h"
/*
*----------------------------------------------------------------------
*
* Pkgd_SubObjCmd --
*
* This procedure is invoked to process the "pkgd_sub" Tcl command. It
* expects two arguments and returns their difference.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
Pkgd_SubObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int first, second;
(void)dummy;
|
| ︙ | ︙ | |||
77 78 79 80 81 82 83 | * See the user documentation. * *---------------------------------------------------------------------- */ static int Pkgd_UnsafeObjCmd( | | | 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
Pkgd_UnsafeObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
(void)dummy;
(void)objc;
(void)objv;
|
| ︙ | ︙ |
Changes to unix/dltest/pkgooa.c.
| ︙ | ︙ | |||
29 30 31 32 33 34 35 | * See the user documentation. * *---------------------------------------------------------------------- */ static int Pkgooa_StubsOKObjCmd( | | | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
Pkgooa_StubsOKObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
(void)dummy;
if (objc != 1) {
|
| ︙ | ︙ | |||
84 85 86 87 88 89 90 91 92 93 94 95 96 97 |
NULL, NULL, NULL, NULL, NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL, NULL, NULL
#ifdef Tcl_MethodIsPrivate
,NULL
#endif
};
DLLEXPORT int
Pkgooa_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
| > > > > > > | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 |
NULL, NULL, NULL, NULL, NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL, NULL, NULL
#ifdef Tcl_MethodIsPrivate
,NULL
#endif
#ifdef Tcl_GetClassOfObject
,NULL
#endif
#ifdef Tcl_GetObjectClassName
,NULL
#endif
};
DLLEXPORT int
Pkgooa_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
|
| ︙ | ︙ | |||
105 106 107 108 109 110 111 |
* This worked in Tcl 8.6.0, and is expected
* to keep working in all future Tcl 8.x releases.
*/
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
if (tclStubsPtr == NULL) {
| | | | | 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 |
* This worked in Tcl 8.6.0, and is expected
* to keep working in all future Tcl 8.x releases.
*/
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
if (tclStubsPtr == NULL) {
Tcl_AppendResult(interp, "Tcl stubs are not initialized, "
"did you compile using -DUSE_TCL_STUBS? ");
return TCL_ERROR;
}
if (Tcl_OOInitStubs(interp) == NULL) {
return TCL_ERROR;
}
if (tclOOStubsPtr == NULL) {
Tcl_AppendResult(interp, "TclOO stubs are not initialized");
return TCL_ERROR;
}
if (tclOOIntStubsPtr == NULL) {
Tcl_AppendResult(interp, "TclOO internal stubs are not initialized");
return TCL_ERROR;
}
/* Test case for Bug [f51efe99a7].
*
* Let tclOOStubsPtr point to an alternate stub table
* (with only a single function, that's enough for
|
| ︙ | ︙ |
Changes to unix/dltest/pkgua.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tcl.h" | < < < < < < < < < < | | 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 40 41 |
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tcl.h"
/*
* In the following hash table we are going to store a struct that holds all
* the command tokens created by Tcl_CreateObjCommand in an interpreter,
* indexed by the interpreter. In this way, we can find which command tokens
* we have registered in a specific interpreter, in order to unload them. We
* need to keep the various command tokens we have registered, as they are the
* only safe way to unregister our registered commands, even if they have been
* renamed.
*/
typedef struct ThreadSpecificData {
int interpTokenMapInitialised;
Tcl_HashTable interpTokenMap;
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#define MAX_REGISTERED_COMMANDS 2
static void
CommandDeleted(void *clientData)
{
Tcl_Command *cmdToken = (Tcl_Command *)clientData;
*cmdToken = NULL;
}
static void
PkguaInitTokensHashTable(void)
|
| ︙ | ︙ | |||
126 127 128 129 130 131 132 | * See the user documentation. * *---------------------------------------------------------------------- */ static int PkguaEqObjCmd( | | | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
PkguaEqObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int result;
const char *str1, *str2;
int len1, len2;
|
| ︙ | ︙ | |||
171 172 173 174 175 176 177 | * See the user documentation. * *---------------------------------------------------------------------- */ static int PkguaQuoteObjCmd( | | | 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
PkguaQuoteObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
(void)dummy;
if (objc != 2) {
|
| ︙ | ︙ |
Changes to unix/dltest/pkgπ.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #undef STATIC_BUILD #include "tcl.h" | < < < < < < < | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #undef STATIC_BUILD #include "tcl.h" /* *---------------------------------------------------------------------- * * Pkga_EqObjCmd -- * * This procedure is invoked to process the "pkga_eq" Tcl command. It * expects two arguments and returns 1 if they are the same, 0 if they |
| ︙ | ︙ |
Changes to unix/tclAppInit.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | * Copyright (c) 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tcl.h" | | > > > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | * Copyright (c) 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tcl.h" #if TCL_MAJOR_VERSION < 9 # if defined(USE_TCL_STUBS) # error "Don't build with USE_TCL_STUBS!" # endif # if TCL_MINOR_VERSION < 7 # define Tcl_LibraryInitProc Tcl_PackageInitProc # define Tcl_StaticLibrary Tcl_StaticPackage # endif #endif #ifdef TCL_TEST extern Tcl_LibraryInitProc Tcltest_Init; extern Tcl_LibraryInitProc Tcltest_SafeInit; #endif /* TCL_TEST */ |
| ︙ | ︙ | |||
82 83 84 85 86 87 88 |
#ifdef TCL_LOCAL_MAIN_HOOK
TCL_LOCAL_MAIN_HOOK(&argc, &argv);
#elif (TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6) && (!defined(_WIN32) || defined(UNICODE))
/* New in Tcl 8.7. This doesn't work on Windows without UNICODE */
TclZipfs_AppHook(&argc, &argv);
#endif
| | | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 |
#ifdef TCL_LOCAL_MAIN_HOOK
TCL_LOCAL_MAIN_HOOK(&argc, &argv);
#elif (TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6) && (!defined(_WIN32) || defined(UNICODE))
/* New in Tcl 8.7. This doesn't work on Windows without UNICODE */
TclZipfs_AppHook(&argc, &argv);
#endif
Tcl_Main((size_t)argc, argv, TCL_LOCAL_APPINIT);
return 0; /* Needed only to prevent compiler warning. */
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppInit --
|
| ︙ | ︙ | |||
109 110 111 112 113 114 115 |
*----------------------------------------------------------------------
*/
int
Tcl_AppInit(
Tcl_Interp *interp) /* Interpreter for application. */
{
| | | 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 |
*----------------------------------------------------------------------
*/
int
Tcl_AppInit(
Tcl_Interp *interp) /* Interpreter for application. */
{
if (Tcl_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
#ifdef TCL_XT_TEST
if (Tclxttest_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
151 152 153 154 155 156 157 |
* Specify a user-specific startup file to invoke if the application is
* run interactively. Typically the startup file is "~/.apprc" where "app"
* is the name of the application. If this line is deleted then no
* user-specific startup file will be run under any conditions.
*/
#ifdef DJGPP
| | | | | | 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 |
* Specify a user-specific startup file to invoke if the application is
* run interactively. Typically the startup file is "~/.apprc" where "app"
* is the name of the application. If this line is deleted then no
* user-specific startup file will be run under any conditions.
*/
#ifdef DJGPP
Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", TCL_INDEX_NONE), NULL,
Tcl_NewStringObj("~/tclsh.rc", TCL_INDEX_NONE), TCL_GLOBAL_ONLY);
#else
Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", TCL_INDEX_NONE), NULL,
Tcl_NewStringObj("~/.tclshrc", TCL_INDEX_NONE), TCL_GLOBAL_ONLY);
#endif
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to unix/tclEpollNotfy.c.
| ︙ | ︙ | |||
38 39 40 41 42 43 44 |
int mask; /* Mask of desired events: TCL_READABLE,
* etc. */
int readyMask; /* Mask of events that have been seen since
* the last time file handlers were invoked
* for this file. */
Tcl_FileProc *proc; /* Function to call, in the style of
* Tcl_CreateFileHandler. */
| | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
int mask; /* Mask of desired events: TCL_READABLE,
* etc. */
int readyMask; /* Mask of events that have been seen since
* the last time file handlers were invoked
* for this file. */
Tcl_FileProc *proc; /* Function to call, in the style of
* Tcl_CreateFileHandler. */
void *clientData; /* Argument to pass to proc. */
struct FileHandler *nextPtr;/* Next in list of all files we care about. */
LIST_ENTRY(FileHandler) readyNode;
/* Next/previous in list of FileHandlers asso-
* ciated with regular files (S_IFREG) that are
* ready for I/O. */
struct PlatformEventData *pedPtr;
/* Pointer to PlatformEventData associating this
|
| ︙ | ︙ | |||
146 147 148 149 150 151 152 | * Side effects: * If no initNotifierProc notifier hook exists, PlatformEventsInit is * called. * *---------------------------------------------------------------------- */ | | | 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 |
* Side effects:
* If no initNotifierProc notifier hook exists, PlatformEventsInit is
* called.
*
*----------------------------------------------------------------------
*/
void *
TclpInitNotifier(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
PlatformEventsInit();
return tsdPtr;
}
|
| ︙ | ︙ | |||
271 272 273 274 275 276 277 | * tsdPtr->notifierMutex is destroyed. * *---------------------------------------------------------------------- */ void TclpFinalizeNotifier( | | | 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 |
* tsdPtr->notifierMutex is destroyed.
*
*----------------------------------------------------------------------
*/
void
TclpFinalizeNotifier(
TCL_UNUSED(void *))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
pthread_mutex_lock(&tsdPtr->notifierMutex);
#ifdef HAVE_EVENTFD
if (tsdPtr->triggerEventFd) {
close(tsdPtr->triggerEventFd);
|
| ︙ | ︙ | |||
509 510 511 512 513 514 515 |
int fd, /* Handle of stream to watch. */
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. */
Tcl_FileProc *proc, /* Function to call for each selected
* event. */
| | | 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 |
int fd, /* Handle of stream to watch. */
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. */
Tcl_FileProc *proc, /* Function to call for each selected
* event. */
void *clientData) /* Arbitrary data to pass to proc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL);
int isNew = (filePtr == NULL);
if (isNew) {
filePtr = (FileHandler *) Tcl_Alloc(sizeof(FileHandler));
|
| ︙ | ︙ | |||
787 788 789 790 791 792 793 |
*----------------------------------------------------------------------
*/
int
TclAsyncNotifier(
int sigNumber, /* Signal number. */
Tcl_ThreadId threadId, /* Target thread. */
| | | 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 |
*----------------------------------------------------------------------
*/
int
TclAsyncNotifier(
int sigNumber, /* Signal number. */
Tcl_ThreadId threadId, /* Target thread. */
void *clientData, /* Notifier data. */
int *flagPtr, /* Flag to mark. */
int value) /* Value of mark. */
{
#if TCL_THREADS
/*
* WARNING:
* This code most likely runs in a signal handler. Thus,
|
| ︙ | ︙ |
Changes to unix/tclKqueueNotfy.c.
| ︙ | ︙ | |||
36 37 38 39 40 41 42 |
int mask; /* Mask of desired events: TCL_READABLE,
* etc. */
int readyMask; /* Mask of events that have been seen since
* the last time file handlers were invoked
* for this file. */
Tcl_FileProc *proc; /* Function to call, in the style of
* Tcl_CreateFileHandler. */
| | | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 |
int mask; /* Mask of desired events: TCL_READABLE,
* etc. */
int readyMask; /* Mask of events that have been seen since
* the last time file handlers were invoked
* for this file. */
Tcl_FileProc *proc; /* Function to call, in the style of
* Tcl_CreateFileHandler. */
void *clientData; /* Argument to pass to proc. */
struct FileHandler *nextPtr;/* Next in list of all files we care about. */
LIST_ENTRY(FileHandler) readyNode;
/* Next/previous in list of FileHandlers asso-
* ciated with regular files (S_IFREG) that are
* ready for I/O. */
struct PlatformEventData *pedPtr;
/* Pointer to PlatformEventData associating this
|
| ︙ | ︙ | |||
270 271 272 273 274 275 276 | * tsdPtr->notifierMutex is destroyed. * *---------------------------------------------------------------------- */ void TclpFinalizeNotifier( | | | 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 |
* tsdPtr->notifierMutex is destroyed.
*
*----------------------------------------------------------------------
*/
void
TclpFinalizeNotifier(
TCL_UNUSED(void *))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
pthread_mutex_lock(&tsdPtr->notifierMutex);
if (tsdPtr->triggerPipe[0]) {
close(tsdPtr->triggerPipe[0]);
tsdPtr->triggerPipe[0] = -1;
|
| ︙ | ︙ | |||
326 327 328 329 330 331 332 | * fd(2), registering interest for TCL_READABLE on it via Platform- * EventsControl(). * - readyEvents and maxReadyEvents are initialised with 512 kevents. * *---------------------------------------------------------------------- */ | | | 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 |
* fd(2), registering interest for TCL_READABLE on it via Platform-
* EventsControl().
* - readyEvents and maxReadyEvents are initialised with 512 kevents.
*
*----------------------------------------------------------------------
*/
void *
TclpInitNotifier(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
int i, fdFl;
FileHandler *filePtr;
errno = pthread_mutex_init(&tsdPtr->notifierMutex, NULL);
|
| ︙ | ︙ | |||
514 515 516 517 518 519 520 |
int fd, /* Handle of stream to watch. */
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. */
Tcl_FileProc *proc, /* Function to call for each selected
* event. */
| | | 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 |
int fd, /* Handle of stream to watch. */
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. */
Tcl_FileProc *proc, /* Function to call for each selected
* event. */
void *clientData) /* Arbitrary data to pass to proc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL);
int isNew = (filePtr == NULL);
if (isNew) {
filePtr = (FileHandler *) Tcl_Alloc(sizeof(FileHandler));
|
| ︙ | ︙ | |||
783 784 785 786 787 788 789 |
*----------------------------------------------------------------------
*/
int
TclAsyncNotifier(
int sigNumber, /* Signal number. */
Tcl_ThreadId threadId, /* Target thread. */
| | | 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 |
*----------------------------------------------------------------------
*/
int
TclAsyncNotifier(
int sigNumber, /* Signal number. */
Tcl_ThreadId threadId, /* Target thread. */
void *clientData, /* Notifier data. */
int *flagPtr, /* Flag to mark. */
int value) /* Value of mark. */
{
#if TCL_THREADS
/*
* WARNING:
* This code most likely runs in a signal handler. Thus,
|
| ︙ | ︙ |
Changes to unix/tclLoadDl.c.
| ︙ | ︙ | |||
104 105 106 107 108 109 110 | * string the user gave us which hopefully refers to a file on the * binary path. */ Tcl_DString ds; const char *fileName = TclGetString(pathPtr); | | | 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 |
* string the user gave us which hopefully refers to a file on the
* binary path.
*/
Tcl_DString ds;
const char *fileName = TclGetString(pathPtr);
native = Tcl_UtfToExternalDString(NULL, fileName, TCL_INDEX_NONE, &ds);
/*
* Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
*/
handle = dlopen(native, dlopenflags);
Tcl_DStringFree(&ds);
}
|
| ︙ | ︙ | |||
175 176 177 178 179 180 181 |
/*
* Some platforms still add an underscore to the beginning of symbol
* names. If we can't find a name without an underscore, try again with
* the underscore.
*/
| | | | | | 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 |
/*
* Some platforms still add an underscore to the beginning of symbol
* names. If we can't find a name without an underscore, try again with
* the underscore.
*/
native = Tcl_UtfToExternalDString(NULL, symbol, TCL_INDEX_NONE, &ds);
proc = dlsym(handle, native); /* INTL: Native. */
if (proc == NULL) {
Tcl_DStringInit(&newName);
TclDStringAppendLiteral(&newName, "_");
native = Tcl_DStringAppend(&newName, native, TCL_INDEX_NONE);
proc = dlsym(handle, native); /* INTL: Native. */
Tcl_DStringFree(&newName);
}
#ifdef __cplusplus
if (proc == NULL) {
char buf[32];
sprintf(buf, "%d", (int)Tcl_DStringLength(&ds));
Tcl_DStringInit(&newName);
TclDStringAppendLiteral(&newName, "__Z");
Tcl_DStringAppend(&newName, buf, TCL_INDEX_NONE);
Tcl_DStringAppend(&newName, Tcl_DStringValue(&ds), TCL_INDEX_NONE);
TclDStringAppendLiteral(&newName, "P10Tcl_Interp");
native = Tcl_DStringValue(&newName);
proc = dlsym(handle, native + 1); /* INTL: Native. */
if (proc == NULL) {
proc = dlsym(handle, native); /* INTL: Native. */
}
if (proc == NULL) {
|
| ︙ | ︙ |
Changes to unix/tclLoadDyld.c.
| ︙ | ︙ | |||
181 182 183 184 185 186 187 |
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
nativePath = (const char *)Tcl_FSGetNativePath(pathPtr);
nativeFileName = Tcl_UtfToExternalDString(NULL, TclGetString(pathPtr),
| | | 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 |
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
nativePath = (const char *)Tcl_FSGetNativePath(pathPtr);
nativeFileName = Tcl_UtfToExternalDString(NULL, TclGetString(pathPtr),
TCL_INDEX_NONE, &ds);
#if TCL_DYLD_USE_DLFCN
/*
* Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
*/
if (flags & TCL_LOAD_GLOBAL) {
|
| ︙ | ︙ | |||
292 293 294 295 296 297 298 |
*loadHandle = newHandle;
result = TCL_OK;
} else {
Tcl_Obj *errObj;
TclNewObj(errObj);
if (errMsg != NULL) {
| | | 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 |
*loadHandle = newHandle;
result = TCL_OK;
} else {
Tcl_Obj *errObj;
TclNewObj(errObj);
if (errMsg != NULL) {
Tcl_AppendToObj(errObj, errMsg, TCL_INDEX_NONE);
}
#if TCL_DYLD_USE_NSMODULE
if (objFileImageErrMsg) {
Tcl_AppendPrintfToObj(errObj,
"\nNSCreateObjectFileImageFromFile() error: %s",
objFileImageErrMsg);
}
|
| ︙ | ︙ | |||
337 338 339 340 341 342 343 |
{
Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *)loadHandle->clientData;
Tcl_LibraryInitProc *proc = NULL;
const char *errMsg = NULL;
Tcl_DString ds;
const char *native;
| | | | 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 364 365 366 367 368 369 370 |
{
Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *)loadHandle->clientData;
Tcl_LibraryInitProc *proc = NULL;
const char *errMsg = NULL;
Tcl_DString ds;
const char *native;
native = Tcl_UtfToExternalDString(NULL, symbol, TCL_INDEX_NONE, &ds);
if (dyldLoadHandle->dlHandle) {
#if TCL_DYLD_USE_DLFCN
proc = (Tcl_LibraryInitProc *)dlsym(dyldLoadHandle->dlHandle, native);
if (!proc) {
errMsg = dlerror();
}
#endif /* TCL_DYLD_USE_DLFCN */
} else {
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
NSSymbol nsSymbol = NULL;
Tcl_DString newName;
/*
* dyld adds an underscore to the beginning of symbol names.
*/
Tcl_DStringInit(&newName);
TclDStringAppendLiteral(&newName, "_");
native = Tcl_DStringAppend(&newName, native, TCL_INDEX_NONE);
if (dyldLoadHandle->dyldLibHeader) {
nsSymbol = NSLookupSymbolInImage(dyldLoadHandle->dyldLibHeader,
native, NSLOOKUPSYMBOLINIMAGE_OPTION_BIND_NOW |
NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR);
if (nsSymbol) {
/*
* Until dyld supports unloading of MY_DYLIB binaries, the
|
| ︙ | ︙ | |||
652 653 654 655 656 657 658 |
NSDestroyObjectFileImage(dyldObjFileImage);
if (!module) {
NSLinkEditErrors editError;
int errorNumber;
const char *errorName, *errMsg;
NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg);
| | | 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 |
NSDestroyObjectFileImage(dyldObjFileImage);
if (!module) {
NSLinkEditErrors editError;
int errorNumber;
const char *errorName, *errMsg;
NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg);
Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, TCL_INDEX_NONE));
return TCL_ERROR;
}
/*
* Stash the module reference within the load handle we create and return.
*/
|
| ︙ | ︙ |
Changes to unix/tclLoadNext.c.
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | * Let the OS loader examine the binary search path for whatever * string the user gave us which hopefully refers to a file on the * binary path */ Tcl_DString ds; | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 |
* Let the OS loader examine the binary search path for whatever
* string the user gave us which hopefully refers to a file on the
* binary path
*/
Tcl_DString ds;
native = Tcl_UtfToExternalDString(NULL, fileName, TCL_INDEX_NONE, &ds);
files = {native,NULL};
result = rld_load(errorStream, &header, files, NULL);
Tcl_DStringFree(&ds);
}
if (!result) {
char *data;
|
| ︙ | ︙ |
Changes to unix/tclLoadOSF.c.
| ︙ | ︙ | |||
96 97 98 99 100 101 102 | * Let the OS loader examine the binary search path for whatever * string the user gave us which hopefully refers to a file on the * binary path */ Tcl_DString ds; | | | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 |
* Let the OS loader examine the binary search path for whatever
* string the user gave us which hopefully refers to a file on the
* binary path
*/
Tcl_DString ds;
native = Tcl_UtfToExternalDString(NULL, fileName, TCL_INDEX_NONE, &ds);
lm = (Tcl_LibraryInitProc *) load(native, LDR_NOFLAGS);
Tcl_DStringFree(&ds);
}
if (lm == LDR_NULL_MODULE) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s",
|
| ︙ | ︙ |
Changes to unix/tclLoadShl.c.
| ︙ | ︙ | |||
82 83 84 85 86 87 88 | * Let the OS loader examine the binary search path for whatever * string the user gave us which hopefully refers to a file on the * binary path. */ Tcl_DString ds; | | | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 |
* Let the OS loader examine the binary search path for whatever
* string the user gave us which hopefully refers to a file on the
* binary path.
*/
Tcl_DString ds;
native = Tcl_UtfToExternalDString(NULL, fileName, TCL_INDEX_NONE, &ds);
handle = shl_load(native, BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH, 0L);
Tcl_DStringFree(&ds);
}
if (handle == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s",
|
| ︙ | ︙ | |||
136 137 138 139 140 141 142 |
* of exported symbols while others don't; try both forms of each name.
*/
if (shl_findsym(&handle, symbol, (short) TYPE_PROCEDURE,
(void *) &proc) != 0) {
Tcl_DStringInit(&newName);
TclDStringAppendLiteral(&newName, "_");
| | | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 |
* of exported symbols while others don't; try both forms of each name.
*/
if (shl_findsym(&handle, symbol, (short) TYPE_PROCEDURE,
(void *) &proc) != 0) {
Tcl_DStringInit(&newName);
TclDStringAppendLiteral(&newName, "_");
Tcl_DStringAppend(&newName, symbol, TCL_INDEX_NONE);
if (shl_findsym(&handle, Tcl_DStringValue(&newName),
(short) TYPE_PROCEDURE, (void *) &proc) != 0) {
proc = NULL;
}
Tcl_DStringFree(&newName);
}
if (proc == NULL && interp != NULL) {
|
| ︙ | ︙ |
Changes to unix/tclSelectNotfy.c.
| ︙ | ︙ | |||
917 918 919 920 921 922 923 |
*----------------------------------------------------------------------
*/
int
TclAsyncNotifier(
int sigNumber, /* Signal number. */
TCL_UNUSED(Tcl_ThreadId), /* Target thread. */
| | | 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 |
*----------------------------------------------------------------------
*/
int
TclAsyncNotifier(
int sigNumber, /* Signal number. */
TCL_UNUSED(Tcl_ThreadId), /* Target thread. */
TCL_UNUSED(void *), /* Notifier data. */
int *flagPtr, /* Flag to mark. */
int value) /* Value of mark. */
{
#if TCL_THREADS
/*
* WARNING:
* This code most likely runs in a signal handler. Thus,
|
| ︙ | ︙ | |||
982 983 984 985 986 987 988 | * *---------------------------------------------------------------------- */ #if TCL_THREADS static TCL_NORETURN void NotifierThreadProc( | | | 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 |
*
*----------------------------------------------------------------------
*/
#if TCL_THREADS
static TCL_NORETURN void
NotifierThreadProc(
TCL_UNUSED(void *))
{
ThreadSpecificData *tsdPtr;
fd_set readableMask;
fd_set writableMask;
fd_set exceptionMask;
int i, fds[2], receivePipe, ret;
long found;
|
| ︙ | ︙ |
Changes to unix/tclUnixChan.c.
| ︙ | ︙ | |||
592 593 594 595 596 597 598 |
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Which option to set? */
const char *value) /* New value for option. */
{
TtyState *fsPtr = (TtyState *)instanceData;
size_t len, vlen;
TtyAttrs tty;
| | | 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 |
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Which option to set? */
const char *value) /* New value for option. */
{
TtyState *fsPtr = (TtyState *)instanceData;
size_t len, vlen;
TtyAttrs tty;
size_t argc;
const char **argv;
struct termios iostate;
len = strlen(optionName);
vlen = strlen(value);
/*
|
| ︙ | ︙ | |||
727 728 729 730 731 732 733 |
/*
* Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
*/
if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) {
#if defined(TIOCMGET) && defined(TIOCMSET)
| | > | 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 |
/*
* Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
*/
if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) {
#if defined(TIOCMGET) && defined(TIOCMSET)
int control, flag;
size_t i;
if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
}
if ((argc % 2) == 1) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
|
| ︙ | ︙ | |||
1792 1793 1794 1795 1796 1797 1798 |
int mode = 0; /* compiler warning (used before set). */
const char *bufMode = NULL;
/*
* Some #def's to make the code a little clearer!
*/
| < | | | < | 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 |
int mode = 0; /* compiler warning (used before set). */
const char *bufMode = NULL;
/*
* Some #def's to make the code a little clearer!
*/
#define ERROR_OFFSET ((Tcl_SeekOffset) -1)
switch (type) {
case TCL_STDIN:
if ((TclOSseek(0, 0, SEEK_CUR) == ERROR_OFFSET)
&& (errno == EBADF)) {
return NULL;
}
fd = 0;
mode = TCL_READABLE;
bufMode = "line";
break;
case TCL_STDOUT:
if ((TclOSseek(1, 0, SEEK_CUR) == ERROR_OFFSET)
&& (errno == EBADF)) {
return NULL;
}
fd = 1;
mode = TCL_WRITABLE;
bufMode = "line";
break;
case TCL_STDERR:
if ((TclOSseek(2, 0, SEEK_CUR) == ERROR_OFFSET)
&& (errno == EBADF)) {
return NULL;
}
fd = 2;
mode = TCL_WRITABLE;
bufMode = "none";
break;
default:
Tcl_Panic("TclGetDefaultStdChannel: Unexpected channel type");
break;
}
#undef ERROR_OFFSET
channel = Tcl_MakeFileChannel(INT2PTR(fd), mode);
if (channel == NULL) {
return NULL;
}
|
| ︙ | ︙ |
Changes to unix/tclUnixCompat.c.
| ︙ | ︙ | |||
112 113 114 115 116 117 118 | static int CopyHostent(struct hostent *tgtPtr, char *buf, int buflen); static int CopyString(const char *src, char *buf, int buflen); #endif #ifdef NEED_PW_CLEANER | | | | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | static int CopyHostent(struct hostent *tgtPtr, char *buf, int buflen); static int CopyString(const char *src, char *buf, int buflen); #endif #ifdef NEED_PW_CLEANER static void FreePwBuf(void *dummy); #endif #ifdef NEED_GR_CLEANER static void FreeGrBuf(void *dummy); #endif #endif /* TCL_THREADS */ /* *--------------------------------------------------------------------------- * * TclUnixSetBlockingMode -- |
| ︙ | ︙ | |||
330 331 332 333 334 335 336 | * *--------------------------------------------------------------------------- */ #ifdef NEED_PW_CLEANER static void FreePwBuf( | | | 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 |
*
*---------------------------------------------------------------------------
*/
#ifdef NEED_PW_CLEANER
static void
FreePwBuf(
TCL_UNUSED(void *))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_Free(tsdPtr->pbuf);
}
#endif /* NEED_PW_CLEANER */
|
| ︙ | ︙ | |||
513 514 515 516 517 518 519 | * *--------------------------------------------------------------------------- */ #ifdef NEED_GR_CLEANER static void FreeGrBuf( | | | 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 |
*
*---------------------------------------------------------------------------
*/
#ifdef NEED_GR_CLEANER
static void
FreeGrBuf(
TCL_UNUSED(void *))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_Free(tsdPtr->gbuf);
}
#endif /* NEED_GR_CLEANER */
|
| ︙ | ︙ |
Changes to unix/tclUnixFCmd.c.
| ︙ | ︙ | |||
778 779 780 781 782 783 784 |
ret = TraverseUnixTree(TraversalCopy, &srcString, &dstString, &ds, 0);
Tcl_DStringFree(&srcString);
Tcl_DStringFree(&dstString);
if (ret != TCL_OK) {
| | | 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 |
ret = TraverseUnixTree(TraversalCopy, &srcString, &dstString, &ds, 0);
Tcl_DStringFree(&srcString);
Tcl_DStringFree(&dstString);
if (ret != TCL_OK) {
*errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), TCL_INDEX_NONE);
Tcl_DStringFree(&ds);
Tcl_IncrRefCount(*errorPtr);
}
return ret;
}
/*
|
| ︙ | ︙ | |||
832 833 834 835 836 837 838 |
if (transPtr != NULL) {
Tcl_DecrRefCount(transPtr);
}
ret = DoRemoveDirectory(&pathString, recursive, &ds);
Tcl_DStringFree(&pathString);
if (ret != TCL_OK) {
| | | 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 |
if (transPtr != NULL) {
Tcl_DecrRefCount(transPtr);
}
ret = DoRemoveDirectory(&pathString, recursive, &ds);
Tcl_DStringFree(&pathString);
if (ret != TCL_OK) {
*errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), TCL_INDEX_NONE);
Tcl_DStringFree(&ds);
Tcl_IncrRefCount(*errorPtr);
}
return ret;
}
static int
|
| ︙ | ︙ | |||
882 883 884 885 886 887 888 |
if (errno == ENOTEMPTY) {
errno = EEXIST;
}
result = TCL_OK;
if ((errno != EEXIST) || (recursive == 0)) {
if (errorPtr != NULL) {
| | | 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 |
if (errno == ENOTEMPTY) {
errno = EEXIST;
}
result = TCL_OK;
if ((errno != EEXIST) || (recursive == 0)) {
if (errorPtr != NULL) {
Tcl_ExternalToUtfDStringEx(NULL, path, TCL_INDEX_NONE, TCL_ENCODING_NOCOMPLAIN, errorPtr);
}
result = TCL_ERROR;
}
/*
* The directory is nonempty, but the recursive flag has been specified,
* so we recursively remove all the files in the directory.
|
| ︙ | ︙ | |||
1014 1015 1016 1017 1018 1019 1020 | continue; } /* * Append name after slash, and recurse on the file. */ | | | | 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 |
continue;
}
/*
* Append name after slash, and recurse on the file.
*/
Tcl_DStringAppend(sourcePtr, dirEntPtr->d_name, TCL_INDEX_NONE);
if (targetPtr != NULL) {
Tcl_DStringAppend(targetPtr, dirEntPtr->d_name, TCL_INDEX_NONE);
}
result = TraverseUnixTree(traverseProc, sourcePtr, targetPtr,
errorPtr, doRewind);
if (result != TCL_OK) {
break;
} else {
numProcessed++;
|
| ︙ | ︙ | |||
1131 1132 1133 1134 1135 1136 1137 |
}
}
#endif /* !HAVE_FTS */
end:
if (errfile != NULL) {
if (errorPtr != NULL) {
| | | 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 |
}
}
#endif /* !HAVE_FTS */
end:
if (errfile != NULL) {
if (errorPtr != NULL) {
Tcl_ExternalToUtfDStringEx(NULL, errfile, TCL_INDEX_NONE, TCL_ENCODING_NOCOMPLAIN, errorPtr);
}
result = TCL_ERROR;
}
#ifdef HAVE_FTS
if (fts != NULL) {
fts_close(fts);
}
|
| ︙ | ︙ | |||
1367 1368 1369 1370 1371 1372 1373 |
if (groupPtr == NULL) {
TclNewIntObj(*attributePtrPtr, statBuf.st_gid);
} else {
Tcl_DString ds;
const char *utf;
| | | | 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 |
if (groupPtr == NULL) {
TclNewIntObj(*attributePtrPtr, statBuf.st_gid);
} else {
Tcl_DString ds;
const char *utf;
utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, TCL_INDEX_NONE, &ds);
*attributePtrPtr = Tcl_NewStringObj(utf, TCL_INDEX_NONE);
Tcl_DStringFree(&ds);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1420 1421 1422 1423 1424 1425 1426 |
pwPtr = TclpGetPwUid(statBuf.st_uid);
if (pwPtr == NULL) {
TclNewIntObj(*attributePtrPtr, statBuf.st_uid);
} else {
Tcl_DString ds;
| | | 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 |
pwPtr = TclpGetPwUid(statBuf.st_uid);
if (pwPtr == NULL) {
TclNewIntObj(*attributePtrPtr, statBuf.st_uid);
} else {
Tcl_DString ds;
Tcl_ExternalToUtfDStringEx(NULL, pwPtr->pw_name, TCL_INDEX_NONE, TCL_ENCODING_NOCOMPLAIN, &ds);
*attributePtrPtr = TclDStringToObj(&ds);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1465 1466 1467 1468 1469 1470 1471 |
"could not read \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
*attributePtrPtr = Tcl_ObjPrintf(
| | | 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 |
"could not read \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
*attributePtrPtr = Tcl_ObjPrintf(
"%0#5o", ((int)statBuf.st_mode & 0x7FFF));
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* SetGroupAttribute --
|
| ︙ | ︙ | |||
2178 2179 2180 2181 2182 2183 2184 |
*/
if (dirObj) {
string = Tcl_GetStringFromObj(dirObj, &length);
Tcl_UtfToExternalDStringEx(NULL, string, length, TCL_ENCODING_NOCOMPLAIN, &templ);
} else {
Tcl_DStringInit(&templ);
| | | 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 |
*/
if (dirObj) {
string = Tcl_GetStringFromObj(dirObj, &length);
Tcl_UtfToExternalDStringEx(NULL, string, length, TCL_ENCODING_NOCOMPLAIN, &templ);
} else {
Tcl_DStringInit(&templ);
Tcl_DStringAppend(&templ, DefaultTempDir(), TCL_INDEX_NONE); /* INTL: native */
}
TclDStringAppendLiteral(&templ, "/");
if (basenameObj) {
string = Tcl_GetStringFromObj(basenameObj, &length);
Tcl_UtfToExternalDStringEx(NULL, string, length, TCL_ENCODING_NOCOMPLAIN, &tmp);
|
| ︙ | ︙ | |||
2303 2304 2305 2306 2307 2308 2309 |
*/
if (dirObj) {
string = TclGetString(dirObj);
Tcl_UtfToExternalDStringEx(NULL, string, dirObj->length, TCL_ENCODING_NOCOMPLAIN, &templ);
} else {
Tcl_DStringInit(&templ);
| | | 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 |
*/
if (dirObj) {
string = TclGetString(dirObj);
Tcl_UtfToExternalDStringEx(NULL, string, dirObj->length, TCL_ENCODING_NOCOMPLAIN, &templ);
} else {
Tcl_DStringInit(&templ);
Tcl_DStringAppend(&templ, DefaultTempDir(), TCL_INDEX_NONE); /* INTL: native */
}
if (Tcl_DStringValue(&templ)[Tcl_DStringLength(&templ) - 1] != '/') {
TclDStringAppendLiteral(&templ, "/");
}
if (basenameObj) {
|
| ︙ | ︙ |
Changes to unix/tclUnixFile.c.
| ︙ | ︙ | |||
115 116 117 118 119 120 121 |
TclDStringClear(&buffer);
if (p != name) {
Tcl_DStringAppend(&buffer, name, p - name);
if (p[-1] != '/') {
TclDStringAppendLiteral(&buffer, "/");
}
}
| | | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 |
TclDStringClear(&buffer);
if (p != name) {
Tcl_DStringAppend(&buffer, name, p - name);
if (p[-1] != '/') {
TclDStringAppendLiteral(&buffer, "/");
}
}
name = Tcl_DStringAppend(&buffer, argv0, TCL_INDEX_NONE);
/*
* INTL: The following calls to access() and stat() should not be
* converted to Tclp routines because they need to operate on native
* strings directly.
*/
|
| ︙ | ︙ | |||
151 152 153 154 155 156 157 |
#ifdef DJGPP
if (name[1] == ':')
#else
if (name[0] == '/')
#endif
{
encoding = Tcl_GetEncoding(NULL, NULL);
| | | | | | | 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 |
#ifdef DJGPP
if (name[1] == ':')
#else
if (name[0] == '/')
#endif
{
encoding = Tcl_GetEncoding(NULL, NULL);
Tcl_ExternalToUtfDStringEx(encoding, name, TCL_INDEX_NONE, TCL_ENCODING_NOCOMPLAIN, &utfName);
TclSetObjNameOfExecutable(
Tcl_NewStringObj(Tcl_DStringValue(&utfName), TCL_INDEX_NONE), encoding);
Tcl_DStringFree(&utfName);
goto done;
}
if (TclpGetCwd(NULL, &cwd) == NULL) {
TclSetObjNameOfExecutable(Tcl_NewObj(), NULL);
goto done;
}
/*
* The name is relative to the current working directory. First strip off
* a leading "./", if any, then add the full path name of the current
* working directory.
*/
if ((name[0] == '.') && (name[1] == '/')) {
name += 2;
}
Tcl_DStringInit(&nameString);
Tcl_DStringAppend(&nameString, name, TCL_INDEX_NONE);
Tcl_DStringFree(&buffer);
Tcl_UtfToExternalDStringEx(NULL, Tcl_DStringValue(&cwd),
Tcl_DStringLength(&cwd), TCL_ENCODING_NOCOMPLAIN, &buffer);
if (Tcl_DStringValue(&cwd)[Tcl_DStringLength(&cwd) -1] != '/') {
TclDStringAppendLiteral(&buffer, "/");
}
Tcl_DStringFree(&cwd);
TclDStringAppendDString(&buffer, &nameString);
Tcl_DStringFree(&nameString);
encoding = Tcl_GetEncoding(NULL, NULL);
Tcl_ExternalToUtfDStringEx(encoding, Tcl_DStringValue(&buffer), TCL_INDEX_NONE,
TCL_ENCODING_NOCOMPLAIN, &utfName);
TclSetObjNameOfExecutable(
Tcl_NewStringObj(Tcl_DStringValue(&utfName), TCL_INDEX_NONE), encoding);
Tcl_DStringFree(&utfName);
done:
Tcl_DStringFree(&buffer);
}
#endif
|
| ︙ | ︙ | |||
303 304 305 306 307 308 309 | } } /* * Now open the directory for reading and iterate over the contents. */ | | | 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 |
}
}
/*
* Now open the directory for reading and iterate over the contents.
*/
native = Tcl_UtfToExternalDString(NULL, dirName, TCL_INDEX_NONE, &ds);
if ((TclOSstat(native, &statBuf) != 0) /* INTL: Native. */
|| !S_ISDIR(statBuf.st_mode)) {
Tcl_DStringFree(&dsOrig);
Tcl_DStringFree(&ds);
Tcl_DecrRefCount(fileNamePtr);
return TCL_OK;
|
| ︙ | ︙ | |||
367 368 369 370 371 372 373 | } /* * Now check to see if the file matches, according to both type * and pattern. If so, add the file to the result. */ | | | | 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 |
}
/*
* Now check to see if the file matches, according to both type
* and pattern. If so, add the file to the result.
*/
utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, TCL_INDEX_NONE,
&utfDs);
if (Tcl_StringCaseMatch(utfname, pattern, 0)) {
int typeOk = 1;
if (types != NULL) {
Tcl_DStringSetLength(&ds, nativeDirLen);
native = Tcl_DStringAppend(&ds, entryPtr->d_name, TCL_INDEX_NONE);
matchResult = NativeMatchType(interp, native,
entryPtr->d_name, types);
typeOk = (matchResult == 1);
}
if (typeOk) {
Tcl_ListObjAppendElement(interp, resultPtr,
TclNewFSPathObj(pathPtr, utfname,
|
| ︙ | ︙ | |||
594 595 596 597 598 599 600 |
TclpGetUserHome(
const char *name, /* User name for desired home directory. */
Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with
* name of user's home directory. */
{
struct passwd *pwPtr;
Tcl_DString ds;
| | | | 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 |
TclpGetUserHome(
const char *name, /* User name for desired home directory. */
Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with
* name of user's home directory. */
{
struct passwd *pwPtr;
Tcl_DString ds;
const char *native = Tcl_UtfToExternalDString(NULL, name, TCL_INDEX_NONE, &ds);
pwPtr = TclpGetPwNam(native); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (pwPtr == NULL) {
return NULL;
}
return Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, TCL_INDEX_NONE, bufferPtr);
}
/*
*---------------------------------------------------------------------------
*
* TclpObjAccess --
*
|
| ︙ | ︙ | |||
780 781 782 783 784 785 786 |
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error getting working directory name: %s",
Tcl_PosixError(interp)));
}
return NULL;
}
| | | 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 |
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error getting working directory name: %s",
Tcl_PosixError(interp)));
}
return NULL;
}
return Tcl_ExternalToUtfDString(NULL, buffer, TCL_INDEX_NONE, bufferPtr);
}
/*
*---------------------------------------------------------------------------
*
* TclpReadlink --
*
|
| ︙ | ︙ | |||
815 816 817 818 819 820 821 |
{
#ifndef DJGPP
char link[MAXPATHLEN];
int length;
const char *native;
Tcl_DString ds;
| | | 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 |
{
#ifndef DJGPP
char link[MAXPATHLEN];
int length;
const char *native;
Tcl_DString ds;
native = Tcl_UtfToExternalDString(NULL, path, TCL_INDEX_NONE, &ds);
length = readlink(native, link, sizeof(link)); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (length < 0) {
return NULL;
}
|
| ︙ | ︙ | |||
1057 1058 1059 1060 1061 1062 1063 |
Tcl_Obj *
TclpNativeToNormalized(
ClientData clientData)
{
Tcl_DString ds;
| | | 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 |
Tcl_Obj *
TclpNativeToNormalized(
ClientData clientData)
{
Tcl_DString ds;
Tcl_ExternalToUtfDStringEx(NULL, (const char *) clientData, TCL_INDEX_NONE, TCL_ENCODING_NOCOMPLAIN, &ds);
return TclDStringToObj(&ds);
}
/*
*---------------------------------------------------------------------------
*
* TclNativeCreateNativeRep --
|
| ︙ | ︙ |
Changes to unix/tclUnixInit.c.
| ︙ | ︙ | |||
365 366 367 368 369 370 371 |
tclPlatform = TCL_PLATFORM_UNIX;
#endif
/*
* Make sure, that the standard FDs exist. [Bug 772288]
*/
| | | | | 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 |
tclPlatform = TCL_PLATFORM_UNIX;
#endif
/*
* Make sure, that the standard FDs exist. [Bug 772288]
*/
if (TclOSseek(0, 0, SEEK_CUR) == -1 && errno == EBADF) {
open("/dev/null", O_RDONLY);
}
if (TclOSseek(1, 0, SEEK_CUR) == -1 && errno == EBADF) {
open("/dev/null", O_WRONLY);
}
if (TclOSseek(2, 0, SEEK_CUR) == -1 && errno == EBADF) {
open("/dev/null", O_WRONLY);
}
/*
* The code below causes SIGPIPE (broken pipe) errors to be ignored. This
* is needed so that Tcl processes don't die if they create child
* processes (e.g. using "exec" or "open") that terminate prematurely.
|
| ︙ | ︙ | |||
469 470 471 472 473 474 475 |
* Look for the library relative to the TCL_LIBRARY env variable. If the
* last dirname in the TCL_LIBRARY path does not match the last dirname in
* the installLib variable, use the last dir name of installLib in
* addition to the orginal TCL_LIBRARY path.
*/
str = getenv("TCL_LIBRARY"); /* INTL: Native. */
| | | | | 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 |
* Look for the library relative to the TCL_LIBRARY env variable. If the
* last dirname in the TCL_LIBRARY path does not match the last dirname in
* the installLib variable, use the last dir name of installLib in
* addition to the orginal TCL_LIBRARY path.
*/
str = getenv("TCL_LIBRARY"); /* INTL: Native. */
Tcl_ExternalToUtfDStringEx(NULL, str, TCL_INDEX_NONE, TCL_ENCODING_NOCOMPLAIN, &buffer);
str = Tcl_DStringValue(&buffer);
if ((str != NULL) && (str[0] != '\0')) {
Tcl_DString ds;
size_t pathc;
const char **pathv;
char installLib[LIBRARY_SIZE];
Tcl_DStringInit(&ds);
/*
* Initialize the substrings used when locating an executable. The
* installLib variable computes the path as though the executable is
* installed.
*/
sprintf(installLib, "lib/tcl%s", TCL_VERSION);
/*
* If TCL_LIBRARY is set, search there.
*/
Tcl_ListObjAppendElement(NULL, pathPtr, Tcl_NewStringObj(str, TCL_INDEX_NONE));
Tcl_SplitPath(str, &pathc, &pathv);
if ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc-1]) != 0)) {
/*
* If TCL_LIBRARY is set but refers to a different tcl
* installation than the current version, try fiddling with the
* specified directory to make it refer to this installation by
|
| ︙ | ︙ | |||
533 534 535 536 537 538 539 |
/*
* TODO: Pull this value from the TIP 59 table.
*/
str = defaultLibraryDir;
}
if (str[0] != '\0') {
| | | 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 |
/*
* TODO: Pull this value from the TIP 59 table.
*/
str = defaultLibraryDir;
}
if (str[0] != '\0') {
objPtr = Tcl_NewStringObj(str, TCL_INDEX_NONE);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
}
}
Tcl_DStringFree(&buffer);
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
str = Tcl_GetStringFromObj(pathPtr, lengthPtr);
|
| ︙ | ︙ | |||
630 631 632 633 634 635 636 | Tcl_DString ds; /* * Use a DString so we can modify case. */ Tcl_DStringInit(&ds); | | | | | 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 |
Tcl_DString ds;
/*
* Use a DString so we can modify case.
*/
Tcl_DStringInit(&ds);
encoding = Tcl_DStringAppend(&ds, nl_langinfo(CODESET), TCL_INDEX_NONE);
Tcl_UtfToLower(Tcl_DStringValue(&ds));
knownEncoding = SearchKnownEncodings(encoding);
if (knownEncoding != NULL) {
Tcl_DStringAppend(bufPtr, knownEncoding, TCL_INDEX_NONE);
} else if (NULL != Tcl_GetEncoding(NULL, encoding)) {
Tcl_DStringAppend(bufPtr, encoding, TCL_INDEX_NONE);
}
Tcl_DStringFree(&ds);
if (Tcl_DStringLength(bufPtr)) {
return Tcl_DStringValue(bufPtr);
}
}
#endif /* HAVE_LANGINFO */
|
| ︙ | ︙ | |||
668 669 670 671 672 673 674 |
if (encoding != NULL) {
const char *p;
Tcl_DString ds;
Tcl_DStringInit(&ds);
p = encoding;
| | | | | | | | 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 |
if (encoding != NULL) {
const char *p;
Tcl_DString ds;
Tcl_DStringInit(&ds);
p = encoding;
encoding = Tcl_DStringAppend(&ds, p, TCL_INDEX_NONE);
Tcl_UtfToLower(Tcl_DStringValue(&ds));
knownEncoding = SearchKnownEncodings(encoding);
if (knownEncoding != NULL) {
Tcl_DStringAppend(bufPtr, knownEncoding, TCL_INDEX_NONE);
} else if (NULL != Tcl_GetEncoding(NULL, encoding)) {
Tcl_DStringAppend(bufPtr, encoding, TCL_INDEX_NONE);
}
if (Tcl_DStringLength(bufPtr)) {
Tcl_DStringFree(&ds);
return Tcl_DStringValue(bufPtr);
}
/*
* We didn't recognize the full value as an encoding name. If there is
* an encoding subfield, we can try to guess from that.
*/
for (p = encoding; *p != '\0'; p++) {
if (*p == '.') {
p++;
break;
}
}
if (*p != '\0') {
knownEncoding = SearchKnownEncodings(p);
if (knownEncoding != NULL) {
Tcl_DStringAppend(bufPtr, knownEncoding, TCL_INDEX_NONE);
} else if (NULL != Tcl_GetEncoding(NULL, p)) {
Tcl_DStringAppend(bufPtr, p, TCL_INDEX_NONE);
}
}
Tcl_DStringFree(&ds);
if (Tcl_DStringLength(bufPtr)) {
return Tcl_DStringValue(bufPtr);
}
}
return Tcl_DStringAppend(bufPtr, TCL_DEFAULT_ENCODING, TCL_INDEX_NONE);
}
/*
*---------------------------------------------------------------------------
*
* TclpSetVariables --
*
|
| ︙ | ︙ | |||
858 859 860 861 862 863 864 865 866 867 868 869 870 871 |
Tcl_SetVar2(interp, "tcl_pkgPath", NULL, pkgPath,
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
} else
#endif /* HAVE_COREFOUNDATION */
{
Tcl_SetVar2(interp, "tcl_pkgPath", NULL, pkgPath, TCL_GLOBAL_ONLY);
}
#ifdef DJGPP
Tcl_SetVar2(interp, "tcl_platform", "platform", "dos", TCL_GLOBAL_ONLY);
#else
Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY);
#endif
| > > > > > > > > > > > > | 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 |
Tcl_SetVar2(interp, "tcl_pkgPath", NULL, pkgPath,
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
} else
#endif /* HAVE_COREFOUNDATION */
{
Tcl_SetVar2(interp, "tcl_pkgPath", NULL, pkgPath, TCL_GLOBAL_ONLY);
}
{
/* Some platforms build configure scripts expect ~ expansion so do that */
Tcl_Obj *origPaths;
Tcl_Obj *resolvedPaths;
origPaths = Tcl_GetVar2Ex(interp, "tcl_pkgPath", NULL, TCL_GLOBAL_ONLY);
resolvedPaths = TclResolveTildePathList(origPaths);
if (resolvedPaths != origPaths && resolvedPaths != NULL) {
Tcl_SetVar2Ex(interp, "tcl_pkgPath", NULL,
resolvedPaths, TCL_GLOBAL_ONLY);
}
}
#ifdef DJGPP
Tcl_SetVar2(interp, "tcl_platform", "platform", "dos", TCL_GLOBAL_ONLY);
#else
Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY);
#endif
|
| ︙ | ︙ | |||
896 897 898 899 900 901 902 |
#elif !defined NO_UNAME
if (uname(&name) >= 0) {
const char *native;
unameOK = 1;
| | | 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 |
#elif !defined NO_UNAME
if (uname(&name) >= 0) {
const char *native;
unameOK = 1;
native = Tcl_ExternalToUtfDString(NULL, name.sysname, TCL_INDEX_NONE, &ds);
Tcl_SetVar2(interp, "tcl_platform", "os", native, TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds);
/*
* The following code is a special hack to handle differences in the
* way version information is returned by uname. On most systems the
* full version number is available in name.release. However, under
|
| ︙ | ︙ | |||
959 960 961 962 963 964 965 |
struct passwd *pwEnt = TclpGetPwUid(getuid());
const char *user;
if (pwEnt == NULL) {
user = "";
Tcl_DStringInit(&ds); /* ensure cleanliness */
} else {
| | | 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 |
struct passwd *pwEnt = TclpGetPwUid(getuid());
const char *user;
if (pwEnt == NULL) {
user = "";
Tcl_DStringInit(&ds); /* ensure cleanliness */
} else {
user = Tcl_ExternalToUtfDString(NULL, pwEnt->pw_name, TCL_INDEX_NONE, &ds);
}
Tcl_SetVar2(interp, "tcl_platform", "user", user, TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds);
}
/*
|
| ︙ | ︙ | |||
1008 1009 1010 1011 1012 1013 1014 |
{
size_t i, result = TCL_INDEX_NONE;
const char *env, *p1, *p2;
Tcl_DString envString;
Tcl_DStringInit(&envString);
for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
| | | 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 |
{
size_t i, result = TCL_INDEX_NONE;
const char *env, *p1, *p2;
Tcl_DString envString;
Tcl_DStringInit(&envString);
for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
p1 = Tcl_ExternalToUtfDString(NULL, env, TCL_INDEX_NONE, &envString);
p2 = name;
for (; *p2 == *p1; p1++, p2++) {
/* NULL loop body. */
}
if ((*p1 == '=') && (*p2 == '\0')) {
*lengthPtr = p2 - name;
|
| ︙ | ︙ |
Changes to unix/tclUnixPipe.c.
| ︙ | ︙ | |||
137 138 139 140 141 142 143 |
const char *fname, /* The name of the file to open. */
int mode) /* In what mode to open the file? */
{
int fd;
const char *native;
Tcl_DString ds;
| | | | 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 |
const char *fname, /* The name of the file to open. */
int mode) /* In what mode to open the file? */
{
int fd;
const char *native;
Tcl_DString ds;
native = Tcl_UtfToExternalDString(NULL, fname, TCL_INDEX_NONE, &ds);
fd = TclOSopen(native, mode, 0666); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (fd != -1) {
fcntl(fd, F_SETFD, FD_CLOEXEC);
/*
* If the file is being opened for writing, seek to the end so we can
* append to any data already in the file.
*/
if ((mode & O_WRONLY) && !(mode & O_APPEND)) {
TclOSseek(fd, 0, SEEK_END);
}
/*
* Increment the fd so it can't be 0, which would conflict with the
* NULL return for errors.
*/
|
| ︙ | ︙ | |||
194 195 196 197 198 199 200 |
return NULL;
}
fcntl(fd, F_SETFD, FD_CLOEXEC);
if (contents != NULL) {
Tcl_DString dstring;
char *native;
| | | | 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 |
return NULL;
}
fcntl(fd, F_SETFD, FD_CLOEXEC);
if (contents != NULL) {
Tcl_DString dstring;
char *native;
native = Tcl_UtfToExternalDString(NULL, contents, TCL_INDEX_NONE, &dstring);
if (write(fd, native, Tcl_DStringLength(&dstring)) == -1) {
close(fd);
Tcl_DStringFree(&dstring);
return NULL;
}
Tcl_DStringFree(&dstring);
TclOSseek(fd, 0, SEEK_SET);
}
return MakeFile(fd);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
377 378 379 380 381 382 383 |
int
TclpCreateProcess(
Tcl_Interp *interp, /* Interpreter in which to leave errors that
* occurred when creating the child process.
* Error messages from the child process
* itself are sent to errorFile. */
| | | 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 |
int
TclpCreateProcess(
Tcl_Interp *interp, /* Interpreter in which to leave errors that
* occurred when creating the child process.
* Error messages from the child process
* itself are sent to errorFile. */
size_t argc, /* Number of arguments in following array. */
const char **argv, /* Array of argument strings in UTF-8.
* argv[0] contains the name of the executable
* translated using Tcl_TranslateFileName
* call). Additional arguments have not been
* converted. */
TclFile inputFile, /* If non-NULL, gives the file to use as input
* for the child process. If inputFile file is
|
| ︙ | ︙ | |||
406 407 408 409 410 411 412 |
* process. */
{
TclFile errPipeIn, errPipeOut;
int count, status, fd;
char errSpace[200 + TCL_INTEGER_SPACE];
Tcl_DString *dsArray;
char **newArgv;
| | | | 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 |
* process. */
{
TclFile errPipeIn, errPipeOut;
int count, status, fd;
char errSpace[200 + TCL_INTEGER_SPACE];
Tcl_DString *dsArray;
char **newArgv;
int pid;
size_t i;
errPipeIn = NULL;
errPipeOut = NULL;
pid = -1;
/*
* Create a pipe that the child can use to return error information if
|
| ︙ | ︙ | |||
433 434 435 436 437 438 439 |
* deallocated later
*/
dsArray = (Tcl_DString *)TclStackAlloc(interp, argc * sizeof(Tcl_DString));
newArgv = (char **)TclStackAlloc(interp, (argc+1) * sizeof(char *));
newArgv[argc] = NULL;
for (i = 0; i < argc; i++) {
| | | 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 |
* deallocated later
*/
dsArray = (Tcl_DString *)TclStackAlloc(interp, argc * sizeof(Tcl_DString));
newArgv = (char **)TclStackAlloc(interp, (argc+1) * sizeof(char *));
newArgv[argc] = NULL;
for (i = 0; i < argc; i++) {
newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], TCL_INDEX_NONE, &dsArray[i]);
}
#ifdef USE_VFORK
/*
* After vfork(), do not call code in the child that changes global state,
* because it is using the parent's memory space at that point and writes
* might corrupt the parent: so ensure standard channels are initialized
|
| ︙ | ︙ | |||
1247 1248 1249 1250 1251 1252 1253 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_PidObjCmd( | | | 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_PidObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
Tcl_Channel chan;
PipeState *pipePtr;
size_t i;
|
| ︙ | ︙ |
Changes to unix/tclUnixSock.c.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 | #define SET_BITS(var, bits) ((var) |= (bits)) #define CLEAR_BITS(var, bits) ((var) &= ~(bits)) #define GOT_BITS(var, bits) (((var) & (bits)) != 0) /* "sock" + a pointer in hex + \0 */ #define SOCK_CHAN_LENGTH (4 + sizeof(void *) * 2 + 1) | | | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | #define SET_BITS(var, bits) ((var) |= (bits)) #define CLEAR_BITS(var, bits) ((var) &= ~(bits)) #define GOT_BITS(var, bits) (((var) & (bits)) != 0) /* "sock" + a pointer in hex + \0 */ #define SOCK_CHAN_LENGTH (4 + sizeof(void *) * 2 + 1) #define SOCK_TEMPLATE "sock%" TCL_Z_MODIFIER "x" #undef SOCKET /* Possible conflict with win32 SOCKET */ /* * This is needed to comply with the strict aliasing rules of GCC, but it also * simplifies casting between the different sockaddr types. */ |
| ︙ | ︙ | |||
49 50 51 52 53 54 55 |
TcpState *statePtr;
int fd;
struct TcpFdList *next;
} TcpFdList;
struct TcpState {
Tcl_Channel channel; /* Channel associated with this file. */
| < < < > | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 |
TcpState *statePtr;
int fd;
struct TcpFdList *next;
} TcpFdList;
struct TcpState {
Tcl_Channel channel; /* Channel associated with this file. */
int flags; /* ORed combination of the bitfields defined
* below. */
TcpFdList fds; /* The file descriptors of the sockets. */
int interest; /* Event types of interest */
/*
* Only needed for server sockets
*/
Tcl_TcpAcceptProc *acceptProc;
|
| ︙ | ︙ | |||
91 92 93 94 95 96 97 | #define TCP_ASYNC_CONNECT (1<<1) /* Async connect in progress. */ #define TCP_ASYNC_PENDING (1<<4) /* TcpConnect was called to * process an async connect. This * flag indicates that reentry is * still pending */ #define TCP_ASYNC_FAILED (1<<5) /* An async connect finally failed */ | < < < < < | | 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 | #define TCP_ASYNC_CONNECT (1<<1) /* Async connect in progress. */ #define TCP_ASYNC_PENDING (1<<4) /* TcpConnect was called to * process an async connect. This * flag indicates that reentry is * still pending */ #define TCP_ASYNC_FAILED (1<<5) /* An async connect finally failed */ #define TCP_ASYNC_TEST_MODE (1<<8) /* Async testing activated. Do not * automatically continue connection * process. */ /* * The following defines the maximum length of the listen queue. This is the * number of outstanding yet-to-be-serviced requests for a connection on a * server socket, more than this number of outstanding requests and the |
| ︙ | ︙ | |||
427 428 429 430 431 432 433 | * * Results: * 0 if the connection has completed, -1 if still in progress or there is * an error. * * Side effects: * Processes socket events off the system queue. May process | | | 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 |
*
* Results:
* 0 if the connection has completed, -1 if still in progress or there is
* an error.
*
* Side effects:
* Processes socket events off the system queue. May process
* asynchronous connects.
*
*----------------------------------------------------------------------
*/
static int
WaitForConnect(
TcpState *statePtr, /* State of the socket. */
|
| ︙ | ︙ | |||
464 465 466 467 468 469 470 |
/*
* In socket test mode do not continue with the connect.
* Exceptions are:
* - Call by recv/send and blocking socket
* (errorCodePtr != NULL && !GOT_BITS(flags, TCP_NONBLOCKING))
*/
| | | 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 |
/*
* In socket test mode do not continue with the connect.
* Exceptions are:
* - Call by recv/send and blocking socket
* (errorCodePtr != NULL && !GOT_BITS(flags, TCP_NONBLOCKING))
*/
if (GOT_BITS(statePtr->flags, TCP_ASYNC_TEST_MODE)
&& !(errorCodePtr != NULL
&& !GOT_BITS(statePtr->flags, TCP_NONBLOCKING))) {
*errorCodePtr = EWOULDBLOCK;
return -1;
}
if (errorCodePtr == NULL || GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) {
|
| ︙ | ︙ | |||
866 867 868 869 870 871 872 |
int err;
getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR, (char *) &err,
&optlen);
errno = err;
}
if (errno != 0) {
| | | | | 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 |
int err;
getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR, (char *) &err,
&optlen);
errno = err;
}
if (errno != 0) {
Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(errno), TCL_INDEX_NONE);
}
return TCL_OK;
}
if ((len > 1) && (optionName[1] == 'c') &&
(strncmp(optionName, "-connecting", len) == 0)) {
Tcl_DStringAppend(dsPtr,
GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT) ? "1" : "0", TCL_INDEX_NONE);
return TCL_OK;
}
if ((len == 0) || ((len > 1) && (optionName[1] == 'p') &&
(strncmp(optionName, "-peername", len) == 0))) {
address peername;
socklen_t size = sizeof(peername);
|
| ︙ | ︙ | |||
1344 1345 1346 1347 1348 1349 1350 |
TclUnixSetBlockingMode(statePtr->fds.fd, statePtr->cachedBlocking);
if (error != 0) {
SET_BITS(statePtr->flags, TCP_ASYNC_FAILED);
}
/*
| | | 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 |
TclUnixSetBlockingMode(statePtr->fds.fd, statePtr->cachedBlocking);
if (error != 0) {
SET_BITS(statePtr->flags, TCP_ASYNC_FAILED);
}
/*
* We need to forward the writable event that brought us here, because
* upon reading of getsockopt(SO_ERROR), at least some OSes clear the
* writable state from the socket, and so a subsequent select() on
* behalf of a script level [fileevent] would not fire. It doesn't
* hurt that this is also called in the successful case and will save
* the event mechanism one roundtrip through select().
*/
|
| ︙ | ︙ | |||
1444 1445 1446 1447 1448 1449 1450 |
*/
if (TcpConnect(interp, statePtr) != TCL_OK) {
TcpCloseProc(statePtr, NULL);
return NULL;
}
| | | 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 |
*/
if (TcpConnect(interp, statePtr) != TCL_OK) {
TcpCloseProc(statePtr, NULL);
return NULL;
}
sprintf(channelName, SOCK_TEMPLATE, PTR2INT(statePtr));
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
statePtr, TCL_READABLE | TCL_WRITABLE);
if (Tcl_SetChannelOption(interp, statePtr->channel, "-translation",
"auto crlf") == TCL_ERROR) {
Tcl_CloseEx(NULL, statePtr->channel, 0);
return NULL;
|
| ︙ | ︙ | |||
1511 1512 1513 1514 1515 1516 1517 |
char channelName[SOCK_CHAN_LENGTH];
statePtr = (TcpState *)Tcl_Alloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
statePtr->fds.fd = PTR2INT(sock);
statePtr->flags = 0;
| | | 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 |
char channelName[SOCK_CHAN_LENGTH];
statePtr = (TcpState *)Tcl_Alloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
statePtr->fds.fd = PTR2INT(sock);
statePtr->flags = 0;
sprintf(channelName, SOCK_TEMPLATE, PTR2INT(statePtr));
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
statePtr, mode);
if (Tcl_SetChannelOption(NULL, statePtr->channel, "-translation",
"auto crlf") == TCL_ERROR) {
Tcl_CloseEx(NULL, statePtr->channel, 0);
return NULL;
|
| ︙ | ︙ | |||
1733 1734 1735 1736 1737 1738 1739 |
* Allocate a new TcpState for this socket.
*/
statePtr = (TcpState *)Tcl_Alloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
statePtr->acceptProc = acceptProc;
statePtr->acceptProcData = acceptProcData;
| | | 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 |
* Allocate a new TcpState for this socket.
*/
statePtr = (TcpState *)Tcl_Alloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
statePtr->acceptProc = acceptProc;
statePtr->acceptProcData = acceptProcData;
sprintf(channelName, SOCK_TEMPLATE, PTR2INT(statePtr));
newfds = &statePtr->fds;
} else {
newfds = (TcpFdList *)Tcl_Alloc(sizeof(TcpFdList));
memset(newfds, (int) 0, sizeof(TcpFdList));
fds->next = newfds;
}
newfds->fd = sock;
|
| ︙ | ︙ | |||
1762 1763 1764 1765 1766 1767 1768 |
}
if (statePtr != NULL) {
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
statePtr, 0);
return statePtr->channel;
}
if (interp != NULL) {
| | | | | 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 |
}
if (statePtr != NULL) {
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
statePtr, 0);
return statePtr->channel;
}
if (interp != NULL) {
Tcl_Obj *errorObj = Tcl_NewStringObj("couldn't open socket: ", TCL_INDEX_NONE);
if (errorMsg == NULL) {
errno = my_errno;
Tcl_AppendToObj(errorObj, Tcl_PosixError(interp), TCL_INDEX_NONE);
} else {
Tcl_AppendToObj(errorObj, errorMsg, TCL_INDEX_NONE);
}
Tcl_SetObjResult(interp, errorObj);
}
if (sock != -1) {
close(sock);
}
return NULL;
|
| ︙ | ︙ | |||
1825 1826 1827 1828 1829 1830 1831 |
(void) fcntl(newsock, F_SETFD, FD_CLOEXEC);
newSockState = (TcpState *)Tcl_Alloc(sizeof(TcpState));
memset(newSockState, 0, sizeof(TcpState));
newSockState->flags = 0;
newSockState->fds.fd = newsock;
| | | 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 |
(void) fcntl(newsock, F_SETFD, FD_CLOEXEC);
newSockState = (TcpState *)Tcl_Alloc(sizeof(TcpState));
memset(newSockState, 0, sizeof(TcpState));
newSockState->flags = 0;
newSockState->fds.fd = newsock;
sprintf(channelName, SOCK_TEMPLATE, PTR2INT(newSockState));
newSockState->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
newSockState, TCL_READABLE | TCL_WRITABLE);
Tcl_SetChannelOption(NULL, newSockState->channel, "-translation",
"auto crlf");
if (fds->statePtr->acceptProc != NULL) {
|
| ︙ | ︙ |
Changes to unix/tclUnixTest.c.
| ︙ | ︙ | |||
125 126 127 128 129 130 131 | * None. * *---------------------------------------------------------------------- */ static int TestfilehandlerCmd( | | | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestfilehandlerCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
Pipe *pipePtr;
int i, mask, timeout;
static int initialized = 0;
|
| ︙ | ︙ | |||
306 307 308 309 310 311 312 |
return TCL_ERROR;
}
return TCL_OK;
}
static void
TestFileHandlerProc(
| | | 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 |
return TCL_ERROR;
}
return TCL_OK;
}
static void
TestFileHandlerProc(
void *clientData, /* Points to a Pipe structure. */
int mask) /* Indicates which events happened:
* TCL_READABLE or TCL_WRITABLE. */
{
Pipe *pipePtr = (Pipe *)clientData;
if (mask & TCL_READABLE) {
pipePtr->readCount++;
|
| ︙ | ︙ | |||
339 340 341 342 343 344 345 | * None. * *---------------------------------------------------------------------- */ static int TestfilewaitCmd( | | | | 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestfilewaitCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
int mask, result, timeout;
Tcl_Channel channel;
int fd;
void *data;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "file readable|writable|both timeout");
return TCL_ERROR;
}
channel = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
if (channel == NULL) {
|
| ︙ | ︙ | |||
370 371 372 373 374 375 376 |
} else {
Tcl_AppendResult(interp, "bad argument \"", Tcl_GetString(objv[2]),
"\": must be readable, writable, or both", NULL);
return TCL_ERROR;
}
if (Tcl_GetChannelHandle(channel,
(mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE,
| | | 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 |
} else {
Tcl_AppendResult(interp, "bad argument \"", Tcl_GetString(objv[2]),
"\": must be readable, writable, or both", NULL);
return TCL_ERROR;
}
if (Tcl_GetChannelHandle(channel,
(mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE,
(void **) &data) != TCL_OK) {
Tcl_AppendResult(interp, "couldn't get channel file", NULL);
return TCL_ERROR;
}
fd = PTR2INT(data);
if (Tcl_GetIntFromObj(interp, objv[3], &timeout) != TCL_OK) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
407 408 409 410 411 412 413 | * None. * *---------------------------------------------------------------------- */ static int TestfindexecutableCmd( | | | 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestfindexecutableCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
Tcl_Obj *saveName;
if (objc != 2) {
|
| ︙ | ︙ | |||
449 450 451 452 453 454 455 | * None. * *---------------------------------------------------------------------- */ static int TestforkCmd( | | | 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestforkCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
pid_t pid;
if (objc != 1) {
|
| ︙ | ︙ | |||
495 496 497 498 499 500 501 | * Sets up an signal and async handlers. * *---------------------------------------------------------------------- */ static int TestalarmCmd( | | | 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 |
* Sets up an signal and async handlers.
*
*----------------------------------------------------------------------
*/
static int
TestalarmCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
#ifdef SA_RESTART
unsigned int sec = 1;
struct sigaction action;
|
| ︙ | ︙ | |||
573 574 575 576 577 578 579 | * Resets the value of gotsig back to '0'. * *---------------------------------------------------------------------- */ static int TestgotsigCmd( | | | 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 |
* Resets the value of gotsig back to '0'.
*
*----------------------------------------------------------------------
*/
static int
TestgotsigCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *))
{
Tcl_AppendResult(interp, gotsig, NULL);
gotsig = "0";
return TCL_OK;
|
| ︙ | ︙ | |||
604 605 606 607 608 609 610 | * Changes permissions of specified files. * *--------------------------------------------------------------------------- */ static int TestchmodCmd( | | | 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 |
* Changes permissions of specified files.
*
*---------------------------------------------------------------------------
*/
static int
TestchmodCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
int i, mode;
if (objc < 2) {
|
| ︙ | ︙ |
Changes to unix/tclXtNotify.c.
| ︙ | ︙ | |||
29 30 31 32 33 34 35 |
* time FileHandlerEventProc was called for
* this file. */
XtInputId read; /* Xt read callback handle. */
XtInputId write; /* Xt write callback handle. */
XtInputId except; /* Xt exception callback handle. */
Tcl_FileProc *proc; /* Procedure to call, in the style of
* Tcl_CreateFileHandler. */
| | | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
* time FileHandlerEventProc was called for
* this file. */
XtInputId read; /* Xt read callback handle. */
XtInputId write; /* Xt write callback handle. */
XtInputId except; /* Xt exception callback handle. */
Tcl_FileProc *proc; /* Procedure to call, in the style of
* Tcl_CreateFileHandler. */
void *clientData; /* Argument to pass to proc. */
struct FileHandler *nextPtr;/* Next in list of all files we care about. */
} FileHandler;
/*
* The following structure is what is added to the Tcl event queue when file
* handlers are ready to fire.
*/
|
| ︙ | ︙ | |||
75 76 77 78 79 80 81 | /* * Static routines defined in this file. */ static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); static void FileProc(XtPointer clientData, int *source, XtInputId *id); | | | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 | /* * Static routines defined in this file. */ static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); static void FileProc(XtPointer clientData, int *source, XtInputId *id); static void NotifierExitHandler(void *clientData); static void TimerProc(XtPointer clientData, XtIntervalId *id); static void CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, void *clientData); static void DeleteFileHandler(int fd); static void SetTimer(const Tcl_Time * timePtr); static int WaitForEvent(const Tcl_Time * timePtr); /* * Functions defined in this file for use by users of the Xt Notifier: */ |
| ︙ | ︙ | |||
225 226 227 228 229 230 231 | * Destroys the notifier window. * *---------------------------------------------------------------------- */ static void NotifierExitHandler( | | | 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 |
* Destroys the notifier window.
*
*----------------------------------------------------------------------
*/
static void
NotifierExitHandler(
TCL_UNUSED(void *))
{
if (notifier.currentTimeout != 0) {
XtRemoveTimeOut(notifier.currentTimeout);
}
for (; notifier.firstFileHandlerPtr != NULL; ) {
Tcl_DeleteFileHandler(notifier.firstFileHandlerPtr->fd);
}
|
| ︙ | ︙ | |||
335 336 337 338 339 340 341 |
int fd, /* Handle of stream to watch. */
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. */
Tcl_FileProc *proc, /* Procedure to call for each selected
* event. */
| | | 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 |
int fd, /* Handle of stream to watch. */
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. */
Tcl_FileProc *proc, /* Procedure to call for each selected
* event. */
void *clientData) /* Arbitrary data to pass to proc. */
{
FileHandler *filePtr;
if (!initialized) {
InitNotifier();
}
|
| ︙ | ︙ |
Changes to unix/tclXtTest.c.
| ︙ | ︙ | |||
73 74 75 76 77 78 79 | * None. * *---------------------------------------------------------------------- */ static int TesteventloopCmd( | | | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TesteventloopCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static int *framePtr = NULL;/* Pointer to integer on stack frame of
* innermost invocation of the "wait"
* subcommand. */
|
| ︙ | ︙ |
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.3 |
Changes to win/Makefile.in.
| ︙ | ︙ | |||
571 572 573 574 575 576 577 |
@VC_MANIFEST_EMBED_DLL@
@if test "${ZIPFS_BUILD}" = "1" ; then \
cat ${TCL_ZIP_FILE} >> ${TCL_DLL_FILE}; \
${NATIVE_ZIP} -A ${TCL_DLL_FILE} \
|| echo 'ignore zip-error by adjust sfx process (not executable?)'; \
fi
| | | | 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 |
@VC_MANIFEST_EMBED_DLL@
@if test "${ZIPFS_BUILD}" = "1" ; then \
cat ${TCL_ZIP_FILE} >> ${TCL_DLL_FILE}; \
${NATIVE_ZIP} -A ${TCL_DLL_FILE} \
|| echo 'ignore zip-error by adjust sfx process (not executable?)'; \
fi
${TCL_LIB_FILE}: ${TCL_OBJS} tclWinPanic.$(OBJEXT) ${DDE_OBJS} ${REG_OBJS}
@$(RM) ${TCL_LIB_FILE}
@MAKE_LIB@ ${TCL_OBJS} tclWinPanic.$(OBJEXT) ${DDE_OBJS} ${REG_OBJS}
@POST_MAKE_LIB@
${DDE_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${DDE_OBJS}
@MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
$(COPY) tclsh.exe.manifest ${DDE_DLL_FILE}.manifest
${REG_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${REG_OBJS}
|
| ︙ | ︙ | |||
885 886 887 888 889 890 891 | $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \ done; @echo "Installing package cookiejar 0.2" @for j in $(ROOT_DIR)/library/cookiejar/*.tcl \ $(ROOT_DIR)/library/cookiejar/*.gz; do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \ done; | | | | | | 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 | $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \ done; @echo "Installing package cookiejar 0.2" @for j in $(ROOT_DIR)/library/cookiejar/*.tcl \ $(ROOT_DIR)/library/cookiejar/*.gz; do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \ done; @echo "Installing package http 2.10a4 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/9.0/http-2.10a4.tm"; @echo "Installing package opt 0.4.7"; @for j in $(ROOT_DIR)/library/opt/*.tcl; do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; @echo "Installing package msgcat 1.7.1 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl "$(MODULE_INSTALL_DIR)/9.0/msgcat-1.7.1.tm"; @echo "Installing package tcltest 2.5.5 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/9.0/tcltest-2.5.5.tm"; @echo "Installing package platform 1.0.18 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl "$(MODULE_INSTALL_DIR)/9.0/platform-1.0.18.tm"; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/shell.tcl "$(MODULE_INSTALL_DIR)/9.0/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.vc.
| ︙ | ︙ | |||
422 423 424 425 426 427 428 429 430 431 432 433 434 435 | $(TMP_DIR)\tclWinNotify.obj \ $(TMP_DIR)\tclWinPipe.obj \ $(TMP_DIR)\tclWinSerial.obj \ $(TMP_DIR)\tclWinSock.obj \ $(TMP_DIR)\tclWinThrd.obj \ $(TMP_DIR)\tclWinTime.obj \ !if $(STATIC_BUILD) $(TMP_DIR)\tclWinReg.obj \ $(TMP_DIR)\tclWinDde.obj \ !else $(TMP_DIR)\tcl.res !endif TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) | > | 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 | $(TMP_DIR)\tclWinNotify.obj \ $(TMP_DIR)\tclWinPipe.obj \ $(TMP_DIR)\tclWinSerial.obj \ $(TMP_DIR)\tclWinSock.obj \ $(TMP_DIR)\tclWinThrd.obj \ $(TMP_DIR)\tclWinTime.obj \ !if $(STATIC_BUILD) $(TMP_DIR)\tclWinPanic.obj \ $(TMP_DIR)\tclWinReg.obj \ $(TMP_DIR)\tclWinDde.obj \ !else $(TMP_DIR)\tcl.res !endif TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) |
| ︙ | ︙ |
Changes to win/nmakehlp.c.
| ︙ | ︙ | |||
714 715 716 717 718 719 720 |
{
HANDLE hSearch;
char path[MAX_PATH+1];
size_t dirlen;
int keylen, ret;
WIN32_FIND_DATA finfo;
| | > | > | 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 |
{
HANDLE hSearch;
char path[MAX_PATH+1];
size_t dirlen;
int keylen, ret;
WIN32_FIND_DATA finfo;
if (dir == NULL || keypath == NULL) {
return 2; /* Have no real error reporting mechanism into nmake */
}
dirlen = strlen(dir);
if ((dirlen + 3) > sizeof(path)) {
return 2;
}
strncpy(path, dir, dirlen);
strncpy(path+dirlen, "\\*", 3); /* Including terminating \0 */
keylen = strlen(keypath);
#if 0 /* This function is not available in Visual C++ 6 */
/*
* Use numerics 0 -> FindExInfoStandard,
|
| ︙ | ︙ | |||
784 785 786 787 788 789 790 |
{
size_t i;
int ret;
static const char *paths[] = {"..", "..\\..", "..\\..\\.."};
for (i = 0; i < (sizeof(paths)/sizeof(paths[0])); ++i) {
ret = LocateDependencyHelper(paths[i], keypath);
| | > | 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 |
{
size_t i;
int ret;
static const char *paths[] = {"..", "..\\..", "..\\..\\.."};
for (i = 0; i < (sizeof(paths)/sizeof(paths[0])); ++i) {
ret = LocateDependencyHelper(paths[i], keypath);
if (ret == 0) {
return ret;
}
}
return ret;
}
/*
* Local variables:
|
| ︙ | ︙ |
Changes to win/rules.vc.
| ︙ | ︙ | |||
689 690 691 692 693 694 695 | # DOTVERSION - set as (for example) 2.5 # VERSION - set as (for example 25) #-------------------------------------------------------------- !if [echo REM = This file is generated from rules.vc > versions.vc] !endif !if [echo TCL_MAJOR_VERSION = \>> versions.vc] \ | | | 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 | # DOTVERSION - set as (for example) 2.5 # VERSION - set as (for example 25) #-------------------------------------------------------------- !if [echo REM = This file is generated from rules.vc > versions.vc] !endif !if [echo TCL_MAJOR_VERSION = \>> versions.vc] \ && [nmakehlp -V "$(_TCL_H)" "define TCL_MAJOR_VERSION" >> versions.vc] !endif !if [echo TCL_MINOR_VERSION = \>> versions.vc] \ && [nmakehlp -V "$(_TCL_H)" TCL_MINOR_VERSION >> versions.vc] !endif !if [echo TCL_RELEASE_SERIAL = \>> versions.vc] \ && [nmakehlp -V "$(_TCL_H)" TCL_RELEASE_SERIAL >> versions.vc] !endif |
| ︙ | ︙ | |||
1414 1415 1416 1417 1418 1419 1420 | !if "$(MACHINE)" == "AMD64" || "$(MACHINE)" == "ARM64" OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_DO64BIT !endif !if $(VCVERSION) < 1300 OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64=1 !endif | | | 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 | !if "$(MACHINE)" == "AMD64" || "$(MACHINE)" == "ARM64" OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_DO64BIT !endif !if $(VCVERSION) < 1300 OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64=1 !endif !if $(TCL_MAJOR_VERSION) == 8 !if "$(_USE_64BIT_TIME_T)" == "1" OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T=1 !endif # _ATL_XP_TARGETING - Newer SDK's need this to build for XP COMPILERFLAGS = /D_ATL_XP_TARGETING !endif |
| ︙ | ︙ | |||
1466 1467 1468 1469 1470 1471 1472 | cdebug = $(OPTIMIZATIONS) !if $(SYMBOLS) cdebug = $(cdebug) -Zi !endif !endif # $(DEBUG) | | | | 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 | cdebug = $(OPTIMIZATIONS) !if $(SYMBOLS) cdebug = $(cdebug) -Zi !endif !endif # $(DEBUG) # cwarn includes default warning levels, also C4090 (buggy) and C4146 is useless. cwarn = $(WARNINGS) -wd4090 -wd4146 !if "$(MACHINE)" == "AMD64" || "$(MACHINE)" == "ARM64" # Disable pointer<->int warnings related to cast between different sizes # There are a gadzillion of these due to use of ClientData and # clutter up compiler # output increasing chance of a real warning getting lost. So disable them. # Eventually some day, Tcl will be 64-bit clean. |
| ︙ | ︙ |
Changes to win/tclAppInit.c.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | * Copyright (c) 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tcl.h" | | | | | < < < < | > > > > > > > > > | 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 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | * Copyright (c) 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tcl.h" #if TCL_MAJOR_VERSION < 9 # if defined(USE_TCL_STUBS) # error "Don't build with USE_TCL_STUBS!" # endif # if TCL_MINOR_VERSION < 7 # define Tcl_LibraryInitProc Tcl_PackageInitProc # define Tcl_StaticLibrary Tcl_StaticPackage # endif #endif #ifdef TCL_TEST extern Tcl_LibraryInitProc Tcltest_Init; extern Tcl_LibraryInitProc Tcltest_SafeInit; #endif /* TCL_TEST */ #if defined(STATIC_BUILD) extern Tcl_LibraryInitProc Registry_Init; extern Tcl_LibraryInitProc Dde_Init; extern Tcl_LibraryInitProc Dde_SafeInit; #endif #define WIN32_LEAN_AND_MEAN #define STRICT /* See MSDN Article Q83456 */ #include <windows.h> #undef STRICT #undef WIN32_LEAN_AND_MEAN #include <locale.h> #include <stdlib.h> #include <tchar.h> #if defined(__GNUC__) || defined(TCL_BROKEN_MAINARGS) int _CRT_glob = 0; #endif /* __GNUC__ || TCL_BROKEN_MAINARGS */ #ifdef TCL_BROKEN_MAINARGS static void setargv(int *argcPtr, TCHAR ***argvPtr); #endif /* TCL_BROKEN_MAINARGS */ |
| ︙ | ︙ | |||
132 133 134 135 136 137 138 |
#ifdef TCL_LOCAL_MAIN_HOOK
TCL_LOCAL_MAIN_HOOK(&argc, &argv);
#elif (TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6) && (!defined(_WIN32) || defined(UNICODE))
/* New in Tcl 8.7. This doesn't work on Windows without UNICODE */
TclZipfs_AppHook(&argc, &argv);
#endif
| | | 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 |
#ifdef TCL_LOCAL_MAIN_HOOK
TCL_LOCAL_MAIN_HOOK(&argc, &argv);
#elif (TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6) && (!defined(_WIN32) || defined(UNICODE))
/* New in Tcl 8.7. This doesn't work on Windows without UNICODE */
TclZipfs_AppHook(&argc, &argv);
#endif
Tcl_Main((size_t)argc, argv, TCL_LOCAL_APPINIT);
return 0; /* Needed only to prevent compiler warning. */
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppInit --
|
| ︙ | ︙ | |||
159 160 161 162 163 164 165 |
*----------------------------------------------------------------------
*/
int
Tcl_AppInit(
Tcl_Interp *interp) /* Interpreter for application. */
{
| | | 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 |
*----------------------------------------------------------------------
*/
int
Tcl_AppInit(
Tcl_Interp *interp) /* Interpreter for application. */
{
if (Tcl_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
#if defined(STATIC_BUILD)
if (Registry_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
206 207 208 209 210 211 212 |
/*
* Specify a user-specific startup file to invoke if the application is
* run interactively. Typically the startup file is "~/.apprc" where "app"
* is the name of the application. If this line is deleted then no
* user-specific startup file will be run under any conditions.
*/
| | | | 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 |
/*
* Specify a user-specific startup file to invoke if the application is
* run interactively. Typically the startup file is "~/.apprc" where "app"
* is the name of the application. If this line is deleted then no
* user-specific startup file will be run under any conditions.
*/
Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", TCL_INDEX_NONE), NULL,
Tcl_NewStringObj("~/tclshrc.tcl", TCL_INDEX_NONE), TCL_GLOBAL_ONLY);
return TCL_OK;
}
/*
*-------------------------------------------------------------------------
*
* setargv --
|
| ︙ | ︙ |
Changes to win/tclWinConsole.c.
1 2 3 4 | /* * tclWinConsole.c -- * * This file implements the Windows-specific console functions, and the | | | > > > > > > > | < < | < > > > | > > > > > > > > > > > > | < > > > > | | < > > | > > > > > > > > > > > > > | | < | > > | > | > > > > > | | > | > > > > > > > > > > > > > > > > > > | < > | > > | < > > > > > | < | | < | > > > > > | > | | > > > > > > > > | > > > | < > > > > > | < | > > > > > > > > > > > > > > > > > > > > > > > > | | < > | > > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < | < < < < < | < < | < | < | | | | | < | | | | | | | | | | | | | | | < | | | | | > > > > > > > > > > > > > > > > > | > | > | > | > | > > > > > | > > > > > > > > > > > > | | > > | > > > > > > > > | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > | > > > | > > > > > > | > > | > | > > > > > > > > | > > > > > > > > > > > > > > > > > > | > | > | > > | > > > > > > > > > > > > > > > > > > > > > > > | > | > > > | > > | < < | | | | | | < > > > > > > | < > > > > | > > > > > | > > > > | > | > | | > > > > > > > > | > > > > > > > > > > > > > > > > > | | | | < > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | > | > > > | 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 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 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 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 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 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 219 220 221 222 223 224 225 226 227 228 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 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 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 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 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 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 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 |
/*
* tclWinConsole.c --
*
* This file implements the Windows-specific console functions, and the
* "console" channel driver. Windows 7 or later required.
*
* Copyright © 2022 Ashok P. Nadkarni
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#ifdef TCL_CONSOLE_DEBUG
#undef NDEBUG /* Enable asserts */
#endif
#include "tclWinInt.h"
#include <assert.h>
#include <ctype.h>
/*
* A general note on the design: The console channel driver differs from
* most other drivers in the following respects:
*
* - There can be at most 3 console handles at any time since Windows does
* support allocation of more than one console (with three handles
* corresponding to stdin, stdout, stderr)
*
* - Consoles are created / inherited at process startup. There is currently
* no way in Tcl to programmatically create a console. Even if these were
* added the above Windows limitation would still apply.
*
* - Unlike files, sockets etc. where there is a one-to-one
* correspondence between Tcl channels and operating system handles,
* std* channels are shared amongst threads which means there can be
* multiple Tcl channels corresponding to a single console handle.
*
* - Even with multiple threads, more than one file event handler is
* unlikely. It does not make sense for multiple threads to register
* handlers for stdin because the input would be randomly fragmented amongst
* the threads.
*
* Various design factors are driven by the above, e.g. use of lists instead
* of hash tables (at most 3 console handles) and use of global instead of
* per thread queues which simplifies lock management particularly because
* thread-console relation is not one-one and is likely more performant as
* well with fewer locks needing to be obtained.
*
* Some additional design notes/reminders for the future:
*
* Aligned, synchronous reads are done directly by interpreter thread.
* Unaligned or asynchronous reads are done through the reader thread.
*
* The reader thread does not read ahead. That is, it will not post a read
* until some interpreter thread is actually requesting a read. This is
* because an interpreter may (for example) turn off echo for passwords and
* the read ahead would come in the way of that.
*
* If multiple threads are reading from stdin, the input is sprayed in
* random fashion. This is not good application design and hence no plan to
* address this (not clear what should be done even in theory)
*
* For output, we do not restrict all output to the console writer threads.
* See ConsoleOutputProc for the conditions.
*
* Locks are never held when calling the ReadConsole/WriteConsole API's
* since they may block.
*/
static int gInitialized = 0;
/*
* Permit CONSOLE_BUFFER_SIZE to be defined on build command for stress test.
*
* In theory, at least sizeof(WCHAR) but note the Tcl channel bug
* https://core.tcl-lang.org/tcl/tktview/b3977d199b08e3979a8da970553d5209b3042e9c
* will cause failures in test suite if close to max input line in the suite.
*/
#ifndef CONSOLE_BUFFER_SIZE
#define CONSOLE_BUFFER_SIZE 8000 /* In bytes */
#endif
/*
* Ring buffer for storing data. Actual data is from bufPtr[start]:bufPtr[size-1]
* and bufPtr[0]:bufPtr[length - (size-start)].
*/
#if TCL_MAJOR_VERSION > 8
typedef ptrdiff_t RingSizeT; /* Tcl9 TODO */
#define RingSizeT_MAX PTRDIFF_MAX
#else
typedef int RingSizeT;
#define RingSizeT_MAX INT_MAX
#endif
typedef struct RingBuffer {
char *bufPtr; /* Pointer to buffer storage */
RingSizeT capacity; /* Size of the buffer in RingBufferChar */
RingSizeT start; /* Start of the data within the buffer. */
RingSizeT length; /* Number of RingBufferChar*/
} RingBuffer;
#define RingBufferLength(ringPtr_) ((ringPtr_)->length)
#define RingBufferHasFreeSpace(ringPtr_) ((ringPtr_)->length < (ringPtr_)->capacity)
#define RINGBUFFER_ASSERT(ringPtr_) assert(RingBufferCheck(ringPtr_))
/*
* The Win32 console API does not support non-blocking I/O in any form. Thus
* the actual calls are made on a separate thread. Moreover, separate
* threads are needed for each handle because (for example) blocking on user
* input on stdin should not prevent output to stdout when non-blocking i/o
* is configured at the script level.
*
* In the input (e.g. stdin) case, the console stdin thread is the producer
* writing to the buffer ring buffer. The Tcl interpreter threads are the
* consumer. For the output (e.g. stdout/stderr) case, the Tcl interpreter
* are the producers while the console stdout/stderr threads are the
* consumers.
*
* Consoles are identified purely by handles and multiple threads may open
* them (as stdin/stdout/stderr are shared).
*
* Note on reference counting - a ConsoleHandleInfo instance has multiple
* references to it - one each from every channel that is attached to it
* plus one from the console thread itself which also serves as the reference
* from gConsoleHandleInfoList.
*/
typedef struct ConsoleHandleInfo {
struct ConsoleHandleInfo *nextPtr; /* Process-global list of consoles */
HANDLE console; /* Console handle */
HANDLE consoleThread; /* Handle to thread doing actual i/o on the console */
SRWLOCK lock; /* Controls access to this structure.
* Cheaper than CRITICAL_SECTION but note does not
* support recursive locks or Try* style attempts.*/
CONDITION_VARIABLE consoleThreadCV;/* For awakening console thread */
CONDITION_VARIABLE interpThreadCV; /* For awakening interpthread(s) */
RingBuffer buffer; /* Buffer for data transferred between console
* threads and Tcl threads. For input consoles,
* written by the console thread and read by Tcl
* threads. The converse for output threads */
DWORD initMode; /* Initial console mode. */
DWORD lastError; /* An error caused by the last background
* operation. Set to 0 if no error has been
* detected. */
int numRefs; /* See comments above */
int permissions; /* TCL_READABLE for input consoles, TCL_WRITABLE
* for output. Only one or the other can be set. */
int flags;
#define CONSOLE_DATA_AWAITED 0x0001 /* An interpreter is awaiting data */
} ConsoleHandleInfo;
/*
* This structure describes per-instance data for a console based channel.
*
* Note on locking - this structure has no locks because it is accessed
* only from the thread owning channel EXCEPT when a console traverses it
* looking for a channel that is watching for events on the console. Even
* in that case, no locking is required because that access is only under
* the gConsoleLock lock which prevents the channel from being removed from
* the gWatchingChannelList which in turn means it will not be deallocated
* from under the console thread. Access to individual fields does not need
* to be controlled because
* - the console thread does not write to any fields
* - changes to the nextWatchingChannelPtr field
* - changes to other fields do not matter because after being read for
* queueing events, they are verified again when the event is received
* in the interpreter thread (since they could have changed anyways while
* the event was in-flight on the event queue)
*
* Note on reference counting - a structure instance may be referenced from
* three places:
* - the Tcl channel subsystem. This reference is created when on channel
* opening and dropped on channel close. This also covers the reference
* from gWatchingChannelList since queueing / dequeuing from that list
* happens in conjunction with channel operations.
* - the Tcl event queue entries. This reference is added when the event
* is queued and dropped on receipt.
*/
typedef struct ConsoleChannelInfo {
HANDLE handle; /* Console handle */
Tcl_ThreadId threadId; /* Id of owning thread */
struct ConsoleChannelInfo
*nextWatchingChannelPtr; /* Pointer to next channel watching events. */
Tcl_Channel channel; /* Pointer to channel structure. */
DWORD initMode; /* Initial console mode. */
int numRefs; /* See comments above */
int permissions; /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, or TCL_EXCEPTION: indicates
* which operations are valid on the file. */
int watchMask; /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, or TCL_EXCEPTION: indicates
* which events should be reported. */
int flags; /* State flags */
#define CONSOLE_EVENT_QUEUED 0x0001 /* Notification event already queued */
#define CONSOLE_ASYNC 0x0002 /* Channel is non-blocking. */
#define CONSOLE_READ_OPS 0x0004 /* Channel supports read-related ops. */
} ConsoleChannelInfo;
/*
* The following structure is what is added to the Tcl event queue when
* console events are generated.
*/
typedef struct {
Tcl_Event header; /* Information that is standard for all events. */
ConsoleChannelInfo *chanInfoPtr; /* Pointer to console info structure. Note
* that we still have to verify that the
* console exists before dereferencing this
* pointer. */
} ConsoleEvent;
/*
* Declarations for functions used only in this file.
*/
static int ConsoleBlockModeProc(void *instanceData, int mode);
static void ConsoleCheckProc(void *clientData, int flags);
static int ConsoleCloseProc(void *instanceData,
Tcl_Interp *interp, int flags);
static int ConsoleEventProc(Tcl_Event *evPtr, int flags);
static void ConsoleExitHandler(void *clientData);
static int ConsoleGetHandleProc(void *instanceData,
int direction, void **handlePtr);
static int ConsoleGetOptionProc(void *instanceData,
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
static void ConsoleInit(void);
static int ConsoleInputProc(void *instanceData, char *buf,
int toRead, int *errorCode);
static int ConsoleOutputProc(void *instanceData,
const char *buf, int toWrite, int *errorCode);
static int ConsoleSetOptionProc(void *instanceData,
Tcl_Interp *interp, const char *optionName,
const char *value);
static void ConsoleSetupProc(void *clientData, int flags);
static void ConsoleWatchProc(void *instanceData, int mask);
static void ProcExitHandler(void *clientData);
static void ConsoleThreadActionProc(void *instanceData, int action);
static DWORD ReadConsoleChars(HANDLE hConsole, WCHAR *lpBuffer,
RingSizeT nChars, RingSizeT *nCharsReadPtr);
static DWORD WriteConsoleChars(HANDLE hConsole,
const WCHAR *lpBuffer, RingSizeT nChars,
RingSizeT *nCharsWritten);
static void RingBufferInit(RingBuffer *ringPtr, RingSizeT capacity);
static void RingBufferClear(RingBuffer *ringPtr);
static RingSizeT RingBufferIn(RingBuffer *ringPtr, const char *srcPtr,
RingSizeT srcLen, int partialCopyOk);
static RingSizeT RingBufferOut(RingBuffer *ringPtr, char *dstPtr,
RingSizeT dstCapacity, int partialCopyOk);
static ConsoleHandleInfo *AllocateConsoleHandleInfo(HANDLE consoleHandle,
int permissions);
static ConsoleHandleInfo *FindConsoleInfo(const ConsoleChannelInfo *);
static DWORD WINAPI ConsoleReaderThread(LPVOID arg);
static DWORD WINAPI ConsoleWriterThread(LPVOID arg);
static void NudgeWatchers(HANDLE consoleHandle);
#ifndef NDEBUG
static int RingBufferCheck(const RingBuffer *ringPtr);
#endif
/*
* Static data.
*/
typedef struct {
/* Currently this struct is only used to detect thread initialization */
int notUsed; /* Dummy field */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* All access to static data is controlled through a single process-wide
* lock. A process can have only a single console at a time, with three
* handles for stdin, stdout and stderr. Creation/destruction of consoles is
* a relatively rare event (currently only possible during process start),
* the number of consoles (as opposed to channels) is small (only stdin,
* stdout and stderr), and contention low. More finer-grained locking would
* likely not only complicate implementation but be slower due to multiple
* locks being held. Note console channels also differ from other Tcl
* channel types in that the channel<->OS descriptor mapping is not one-to-one.
*/
SRWLOCK gConsoleLock;
/* Process-wide list of console handles. Access control through gConsoleLock */
static ConsoleHandleInfo *gConsoleHandleInfoList;
/*
* Process-wide list of channels that are listening for events. Again access
* control through gConsoleLock. Common list for all threads is simplifies
* locking and bookkeeping and is workable because in practice multiple
* threads are very unlikely to be all waiting on stdin (not workable
* because input would be randomly distributed to threads)
*/
static ConsoleChannelInfo *gWatchingChannelList;
/*
* This structure describes the channel type structure for command console
* based IO.
*/
static const Tcl_ChannelType consoleChannelType = {
"console", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
NULL, /* Close proc. */
ConsoleInputProc, /* Input proc. */
ConsoleOutputProc, /* Output proc. */
NULL, /* Seek proc. */
ConsoleSetOptionProc, /* Set option proc. */
ConsoleGetOptionProc, /* Get option proc. */
ConsoleWatchProc, /* Set up notifier to watch the channel. */
ConsoleGetHandleProc, /* Get an OS handle from channel. */
ConsoleCloseProc, /* close2proc. */
ConsoleBlockModeProc, /* Set blocking or non-blocking mode. */
NULL, /* Flush proc. */
NULL, /* Handler proc. */
NULL, /* Wide seek proc. */
ConsoleThreadActionProc, /* Thread action proc. */
NULL /* Truncation proc. */
};
/*
*------------------------------------------------------------------------
*
* RingBufferInit --
*
* Initializes the ring buffer to a given size.
*
* Results:
* None.
*
* Side effects:
* Panics on allocation failure.
*
*------------------------------------------------------------------------
*/
static void
RingBufferInit(RingBuffer *ringPtr, RingSizeT capacity)
{
if (capacity <= 0 || capacity > RingSizeT_MAX) {
Tcl_Panic("Internal error: invalid ring buffer capacity requested.");
}
ringPtr->bufPtr = (char *)Tcl_Alloc(capacity);
ringPtr->capacity = capacity;
ringPtr->start = 0;
ringPtr->length = 0;
}
/*
*------------------------------------------------------------------------
*
* RingBufferClear
*
* Clears the contents of a ring buffer.
*
* Results:
* None.
*
* Side effects:
* The allocated internal buffer is freed.
*
*------------------------------------------------------------------------
*/
static void
RingBufferClear(RingBuffer *ringPtr)
{
if (ringPtr->bufPtr) {
Tcl_Free(ringPtr->bufPtr);
ringPtr->bufPtr = NULL;
}
ringPtr->capacity = 0;
ringPtr->start = 0;
ringPtr->length = 0;
}
/*
*------------------------------------------------------------------------
*
* RingBufferIn --
*
* Appends data to the ring buffer.
*
* Results:
* Returns number of bytes copied.
*
* Side effects:
* Internal buffer is updated.
*
*------------------------------------------------------------------------
*/
static RingSizeT
RingBufferIn(
RingBuffer *ringPtr,
const char *srcPtr, /* Source to be copied */
RingSizeT srcLen, /* Length of source */
int partialCopyOk /* If true, partial copy is permitted */
)
{
RingSizeT freeSpace;
RINGBUFFER_ASSERT(ringPtr);
freeSpace = ringPtr->capacity - ringPtr->length;
if (freeSpace < srcLen) {
if (!partialCopyOk) {
return 0;
}
/* Copy only as much as free space allows */
srcLen = freeSpace;
}
if (ringPtr->capacity - ringPtr->start > ringPtr->length) {
/* There is room at the back */
RingSizeT endSpaceStart = ringPtr->start + ringPtr->length;
RingSizeT endSpace = ringPtr->capacity - endSpaceStart;
if (endSpace >= srcLen) {
/* Everything fits at the back */
memmove(endSpaceStart + ringPtr->bufPtr, srcPtr, srcLen);
} else {
/* srcLen > endSpace */
memmove(endSpaceStart + ringPtr->bufPtr, srcPtr, endSpace);
memmove(ringPtr->bufPtr, endSpace + srcPtr, srcLen - endSpace);
}
} else {
/* No room at the back. Existing data wrap to front. */
RingSizeT wrapLen =
ringPtr->start + ringPtr->length - ringPtr->capacity;
memmove(wrapLen + ringPtr->bufPtr, srcPtr, srcLen);
}
ringPtr->length += srcLen;
RINGBUFFER_ASSERT(ringPtr);
return srcLen;
}
/*
*------------------------------------------------------------------------
*
* RingBufferOut --
*
* Moves data out of the ring buffer. If dstPtr is NULL, the data
* is simply removed.
*
* Results:
* Returns number of bytes copied or removed.
*
* Side effects:
* Internal buffer is updated.
*
*------------------------------------------------------------------------
*/
static RingSizeT
RingBufferOut(RingBuffer *ringPtr,
char *dstPtr, /* Buffer for output data. May be NULL */
RingSizeT dstCapacity, /* Size of buffer */
int partialCopyOk) /* If true, return what's available */
{
RingSizeT leadLen;
RINGBUFFER_ASSERT(ringPtr);
if (dstCapacity > ringPtr->length) {
if (dstPtr && !partialCopyOk) {
return 0;
}
dstCapacity = ringPtr->length;
}
if (ringPtr->start <= (ringPtr->capacity - ringPtr->length)) {
/* No content wrap around. So leadLen is entire content */
leadLen = ringPtr->length;
} else {
/* Content wraps around so lead segment stretches to end of buffer */
leadLen = ringPtr->capacity - ringPtr->start;
}
if (leadLen >= dstCapacity) {
if (dstPtr) {
memmove(dstPtr, ringPtr->start + ringPtr->bufPtr, dstCapacity);
}
ringPtr->start += dstCapacity;
} else {
RingSizeT wrapLen = dstCapacity - leadLen;
if (dstPtr) {
memmove(dstPtr,
ringPtr->start + ringPtr->bufPtr,
leadLen);
memmove(
leadLen + dstPtr, ringPtr->bufPtr, wrapLen);
}
ringPtr->start = wrapLen;
}
ringPtr->length -= dstCapacity;
if (ringPtr->start == ringPtr->capacity || ringPtr->length == 0) {
ringPtr->start = 0;
}
RINGBUFFER_ASSERT(ringPtr);
return dstCapacity;
}
#ifndef NDEBUG
static int
RingBufferCheck(const RingBuffer *ringPtr)
{
return (ringPtr->bufPtr != NULL && ringPtr->capacity == CONSOLE_BUFFER_SIZE
&& ringPtr->start < ringPtr->capacity
&& ringPtr->length <= ringPtr->capacity);
}
#endif
/*
*------------------------------------------------------------------------
*
* ReadConsoleChars --
*
* Wrapper for ReadConsoleW.
*
* Results:
* Returns 0 on success, else Windows error code.
*
* Side effects:
* On success the number of characters (not bytes) read is stored in
* *nCharsReadPtr. This will be 0 if the operation was interrupted by
* a Ctrl-C or a CancelIo call.
*
*------------------------------------------------------------------------
*/
static DWORD
ReadConsoleChars(
HANDLE hConsole,
WCHAR *lpBuffer,
RingSizeT nChars,
RingSizeT *nCharsReadPtr)
{
DWORD nRead;
BOOL result;
/*
* If user types a Ctrl-Break or Ctrl-C, ReadConsole will return success
* with ntchars == 0 and GetLastError() will be ERROR_OPERATION_ABORTED.
* If no Ctrl signal handlers have been established, the default signal
* OS handler in a separate thread will terminate the program. If a Ctrl
* signal handler has been established (through an extension for
* example), it will run and take whatever action it deems appropriate.
*
* If one thread closes its channel, it calls CancelSynchronousIo on the
* console handle which results again in success being returned and
* GetLastError() being ERROR_OPERATION_ABORTED but ntchars in
* unmodified.
*
* In both cases above we will return success but with nbytesread as 0.
* This allows caller to check for thread termination etc.
*
* See https://bugs.python.org/issue30237
* or https://github.com/microsoft/terminal/issues/12143
*/
nRead = (DWORD)-1;
result = ReadConsoleW(hConsole, lpBuffer, nChars, &nRead, NULL);
if (result) {
if ((nRead == 0 || nRead == (DWORD)-1)
&& GetLastError() == ERROR_OPERATION_ABORTED) {
nRead = 0;
}
*nCharsReadPtr = nRead;
return 0;
} else
return GetLastError();
}
/*
*------------------------------------------------------------------------
*
* WriteConsoleChars --
*
* Wrapper for WriteConsoleW.
*
* Results:
* Returns 0 on success, Windows error code on failure.
*
* Side effects:
* On success the number of characters (not bytes) written is stored in
* *nCharsWrittenPtr. This will be 0 if the operation was interrupted by
* a Ctrl-C or a CancelIo call.
*
*------------------------------------------------------------------------
*/
static DWORD
WriteConsoleChars(
HANDLE hConsole,
const WCHAR *lpBuffer,
RingSizeT nChars,
RingSizeT *nCharsWrittenPtr)
{
DWORD nCharsWritten;
BOOL result;
/* See comments in ReadConsoleChars, not sure that applies here */
nCharsWritten = (DWORD)-1;
result = WriteConsoleW(hConsole, lpBuffer, nChars, &nCharsWritten, NULL);
if (result) {
if (nCharsWritten == (DWORD) -1) {
nCharsWritten = 0;
}
*nCharsWrittenPtr = nCharsWritten;
return 0;
} else {
return GetLastError();
}
}
/*
*----------------------------------------------------------------------
*
* ConsoleInit --
*
|
| ︙ | ︙ | |||
276 277 278 279 280 281 282 |
ConsoleInit(void)
{
/*
* Check the initialized flag first, then check again in the mutex. This
* is a speed enhancement.
*/
| | | | | | | | 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 |
ConsoleInit(void)
{
/*
* Check the initialized flag first, then check again in the mutex. This
* is a speed enhancement.
*/
if (!gInitialized) {
AcquireSRWLockExclusive(&gConsoleLock);
if (!gInitialized) {
gInitialized = 1;
Tcl_CreateExitHandler(ProcExitHandler, NULL);
}
ReleaseSRWLockExclusive(&gConsoleLock);
}
if (TclThreadDataKeyGet(&dataKey) == NULL) {
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
tsdPtr->notUsed = 0;
Tcl_CreateEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL);
Tcl_CreateThreadExitHandler(ConsoleExitHandler, NULL);
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
313 314 315 316 317 318 319 | * Removes the console event source. * *---------------------------------------------------------------------- */ static void ConsoleExitHandler( | | | 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 |
* Removes the console event source.
*
*----------------------------------------------------------------------
*/
static void
ConsoleExitHandler(
TCL_UNUSED(void *))
{
Tcl_DeleteEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
337 338 339 340 341 342 343 | * Resets the process list. * *---------------------------------------------------------------------- */ static void ProcExitHandler( | | | | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | | < | > > > > > > | | > > > > > > | | | | | | | < < | | > | > | 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 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 807 808 809 810 |
* Resets the process list.
*
*----------------------------------------------------------------------
*/
static void
ProcExitHandler(
TCL_UNUSED(void *))
{
AcquireSRWLockExclusive(&gConsoleLock);
gInitialized = 0;
ReleaseSRWLockExclusive(&gConsoleLock);
}
/*
*------------------------------------------------------------------------
*
* NudgeWatchers --
*
* Wakes up all threads which have file event watchers on the passed
* console handle.
*
* The function locks and releases gConsoleLock.
* Caller must not be holding locks that will violate lock hierarchy.
*
* Results:
* None.
*
* Side effects:
* As above.
*------------------------------------------------------------------------
*/
void NudgeWatchers (HANDLE consoleHandle)
{
ConsoleChannelInfo *chanInfoPtr;
AcquireSRWLockShared(&gConsoleLock); /* Shared-read lock */
for (chanInfoPtr = gWatchingChannelList; chanInfoPtr;
chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) {
/*
* Notify channels interested in our handle AND that have
* a thread attached.
* No lock needed for chanInfoPtr. See ConsoleChannelInfo.
*/
if (chanInfoPtr->handle == consoleHandle
&& chanInfoPtr->threadId != NULL) {
Tcl_ThreadAlert(chanInfoPtr->threadId);
}
}
ReleaseSRWLockShared(&gConsoleLock);
}
/*
*----------------------------------------------------------------------
*
* ConsoleSetupProc --
*
* This procedure is invoked before Tcl_DoOneEvent blocks waiting for an
* event. It walks the channel list and if any input channel has data
* available or output channel has space for data, sets the event loop
* blocking time to 0 so that it will poll immediately.
*
* Results:
* None.
*
* Side effects:
* Adjusts the block time if needed.
*
*----------------------------------------------------------------------
*/
void
ConsoleSetupProc(
TCL_UNUSED(void *),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
ConsoleChannelInfo *chanInfoPtr;
Tcl_Time blockTime = { 0, 0 };
int block = 1;
if (!(flags & TCL_FILE_EVENTS)) {
return;
}
/*
* Walk the list of channels. See general comments for struct
* ConsoleChannelInfo with regard to locking and field access.
*/
AcquireSRWLockShared(&gConsoleLock); /* READ lock - no data modification */
for (chanInfoPtr = gWatchingChannelList; block && chanInfoPtr != NULL;
chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) {
ConsoleHandleInfo *handleInfoPtr;
handleInfoPtr = FindConsoleInfo(chanInfoPtr);
if (handleInfoPtr != NULL) {
AcquireSRWLockShared(&handleInfoPtr->lock);
/* Remember at most one of READABLE, WRITABLE set */
if (chanInfoPtr->watchMask & TCL_READABLE) {
if (RingBufferLength(&handleInfoPtr->buffer) > 0
|| handleInfoPtr->lastError != ERROR_SUCCESS) {
block = 0; /* Input data available */
}
} else if (chanInfoPtr->watchMask & TCL_WRITABLE) {
if (RingBufferHasFreeSpace(&handleInfoPtr->buffer)) {
/* TCL_WRITABLE */
block = 0; /* Output space available */
}
}
ReleaseSRWLockShared(&handleInfoPtr->lock);
}
}
ReleaseSRWLockShared(&gConsoleLock);
if (!block) {
/* At least one channel is readable/writable. Set block time to 0 */
Tcl_SetMaxBlockTime(&blockTime);
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
417 418 419 420 421 422 423 | * May queue an event. * *---------------------------------------------------------------------- */ static void ConsoleCheckProc( | | | > < > > < > > > > | > > > > | | > > > | > > > | > | < > | > > > | > | < | > > > > > > > < | < > | > > | > > | | > | > | | | | | 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 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 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 |
* May queue an event.
*
*----------------------------------------------------------------------
*/
static void
ConsoleCheckProc(
TCL_UNUSED(void *),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
ConsoleChannelInfo *chanInfoPtr;
Tcl_ThreadId me;
int needEvent;
if (!(flags & TCL_FILE_EVENTS)) {
return;
}
me = Tcl_GetCurrentThread();
/*
* Acquire a shared lock. Note this is ok even though we potentially
* modify the chanInfoPtr->flags because chanInfoPtr is only modified
* when it belongs to this thread and no other thread will write to it.
* THe shared lock is intended to protect the global gWatchingChannelList
* as we traverse it.
*/
AcquireSRWLockShared(&gConsoleLock);
for (chanInfoPtr = gWatchingChannelList; chanInfoPtr != NULL;
chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) {
ConsoleHandleInfo *handleInfoPtr;
if (chanInfoPtr->threadId != me) {
/* Some other thread owns the channel */
continue;
}
if (chanInfoPtr->flags & CONSOLE_EVENT_QUEUED) {
/* A notification event already queued. No point in another. */
continue;
}
handleInfoPtr = FindConsoleInfo(chanInfoPtr);
/* Pointer is safe to access as we are holding gConsoleLock */
if (handleInfoPtr == NULL) {
/* Stale event */
continue;
}
needEvent = 0;
AcquireSRWLockShared(&handleInfoPtr->lock);
/* Rememeber channel is read or write, never both */
if (chanInfoPtr->watchMask & TCL_READABLE) {
if (RingBufferLength(&handleInfoPtr->buffer) > 0
|| handleInfoPtr->lastError != ERROR_SUCCESS) {
needEvent = 1; /* Input data available or error/EOF */
}
/*
* TCL_READABLE watch means someone is looking out for data being
* available, let reader thread know. Note channel need not be
* ASYNC! (Bug [baa51423c2])
*/
handleInfoPtr->flags |= CONSOLE_DATA_AWAITED;
WakeConditionVariable(&handleInfoPtr->consoleThreadCV);
}
else if (chanInfoPtr->watchMask & TCL_WRITABLE) {
if (RingBufferHasFreeSpace(&handleInfoPtr->buffer)) {
needEvent = 1; /* Output space available */
}
}
ReleaseSRWLockShared(&handleInfoPtr->lock);
if (needEvent) {
ConsoleEvent *evPtr = (ConsoleEvent *)Tcl_Alloc(sizeof(ConsoleEvent));
/* See note above loop why this can be accessed without locks */
chanInfoPtr->flags |= CONSOLE_EVENT_QUEUED;
chanInfoPtr->numRefs += 1; /* So it does not go away while event
is in queue */
evPtr->header.proc = ConsoleEventProc;
evPtr->chanInfoPtr = chanInfoPtr;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
}
}
ReleaseSRWLockShared(&gConsoleLock);
}
/*
*----------------------------------------------------------------------
*
* ConsoleBlockModeProc --
*
* Set blocking or non-blocking mode on channel.
*
* Results:
* 0 if successful, errno when failed.
*
* Side effects:
* Sets the device into blocking or non-blocking mode.
*
*----------------------------------------------------------------------
*/
static int
ConsoleBlockModeProc(
void *instanceData, /* Instance data for channel. */
int mode) /* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
/*
* Consoles on Windows can not be switched between blocking and
* nonblocking, hence we have to emulate the behavior. This is done in the
* input function by checking against a bit in the state. We set or unset
* the bit here to cause the input function to emulate the correct
* behavior.
*/
if (mode == TCL_MODE_NONBLOCKING) {
chanInfoPtr->flags |= CONSOLE_ASYNC;
} else {
chanInfoPtr->flags &= ~CONSOLE_ASYNC;
}
return 0;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
526 527 528 529 530 531 532 | * Closes the physical channel. * *---------------------------------------------------------------------- */ static int ConsoleCloseProc( | | | > | < > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | > < | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > < < > | > | | | < < < < | < < | < < | 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 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 |
* Closes the physical channel.
*
*----------------------------------------------------------------------
*/
static int
ConsoleCloseProc(
void *instanceData, /* Pointer to ConsoleChannelInfo structure. */
TCL_UNUSED(Tcl_Interp *),
int flags)
{
ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
ConsoleHandleInfo *handleInfoPtr;
int errorCode = 0;
ConsoleChannelInfo **nextPtrPtr;
int closeHandle;
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
return EINVAL;
}
/*
* Don't close the Win32 handle if the handle is a standard channel
* during the thread exit process. Otherwise, one thread may kill the
* stdio of another while exiting. Note an explicit close in script will
* still close the handle. That's historical behavior on all platforms.
*/
if (!TclInThreadExit()
|| ((GetStdHandle(STD_INPUT_HANDLE) != chanInfoPtr->handle)
&& (GetStdHandle(STD_OUTPUT_HANDLE) != chanInfoPtr->handle)
&& (GetStdHandle(STD_ERROR_HANDLE) != chanInfoPtr->handle))) {
closeHandle = 1;
} else {
closeHandle = 0;
}
AcquireSRWLockExclusive(&gConsoleLock);
/* Remove channel from watchers' list */
for (nextPtrPtr = &gWatchingChannelList; *nextPtrPtr != NULL;
nextPtrPtr = &(*nextPtrPtr)->nextWatchingChannelPtr) {
if (*nextPtrPtr == (ConsoleChannelInfo *) chanInfoPtr) {
*nextPtrPtr = (*nextPtrPtr)->nextWatchingChannelPtr;
break;
}
}
handleInfoPtr = FindConsoleInfo(chanInfoPtr);
if (handleInfoPtr) {
/*
* Console thread may be blocked either waiting for console i/o
* or waiting on the condition variable for buffer empty/full
*/
AcquireSRWLockShared(&handleInfoPtr->lock);
if (closeHandle) {
handleInfoPtr->console = INVALID_HANDLE_VALUE;
}
/* Break the thread out of blocking console i/o */
handleInfoPtr->numRefs -= 1; /* Remove reference from this channel */
if (handleInfoPtr->numRefs == 1) {
/*
* Abort the i/o if no other threads are listening on it.
* Note without this check, an input line will be skipped on
* the cancel.
*/
CancelSynchronousIo(handleInfoPtr->consoleThread);
}
/*
* Wake up the console handling thread. Note we do not explicitly
* tell it handle is closed (below). It will find out on next access
*/
WakeConditionVariable(&handleInfoPtr->consoleThreadCV);
ReleaseSRWLockShared(&handleInfoPtr->lock);
}
ReleaseSRWLockExclusive(&gConsoleLock);
chanInfoPtr->channel = NULL;
chanInfoPtr->watchMask = 0;
chanInfoPtr->permissions = 0;
if (closeHandle && chanInfoPtr->handle != INVALID_HANDLE_VALUE) {
if (CloseHandle(chanInfoPtr->handle) == FALSE) {
Tcl_WinConvertError(GetLastError());
errorCode = errno;
}
chanInfoPtr->handle = INVALID_HANDLE_VALUE;
}
/*
* Note, we can check and manipulate numRefs without a lock because
* we have removed it from the watch queue so the console thread cannot
* get at it.
*/
if (chanInfoPtr->numRefs > 1) {
/* There may be references already on the event queue */
chanInfoPtr->numRefs -= 1;
} else {
Tcl_Free(chanInfoPtr);
}
return errorCode;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
643 644 645 646 647 648 649 | * indication is returned in an output argument. * * Side effects: * Reads input from the actual channel. * *---------------------------------------------------------------------- */ | < | | | > | | > > > > > > > > | < < | | > > > | < > > | | < < | | < < | > > > > | < | | < | > > > > > > > > > > > > | > > > > > > | > > > > > > > > | > > > > > > > > > > > > > > > > > > | > > | | | < < < | < | | | < < < < | | | | < < < < < > > > > > > > > > > > | > > | > > > > > > | < | | | | | < < < < | < | > | | > > > > | > > > > < > > > | < > > > > > | | | | > | | < > > | | < | | < > > > | | > > > > | | | < | > | > > | > > > > > | > | > > > > | < | > > | | | | | | > | > > | > > > | | > | | | > | < < > > | | 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 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 1351 1352 1353 1354 1355 1356 |
* indication is returned in an output argument.
*
* Side effects:
* Reads input from the actual channel.
*
*----------------------------------------------------------------------
*/
static int
ConsoleInputProc(
void *instanceData, /* Console state. */
char *bufPtr, /* Where to store data read. */
int bufSize, /* How much space is available in the
* buffer? */
int *errorCode) /* Where to store error code. */
{
ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
ConsoleHandleInfo *handleInfoPtr;
RingSizeT numRead;
if (chanInfoPtr->handle == INVALID_HANDLE_VALUE) {
return 0; /* EOF */
}
*errorCode = 0;
AcquireSRWLockShared(&gConsoleLock);
handleInfoPtr = FindConsoleInfo(chanInfoPtr);
if (handleInfoPtr == NULL) {
/* Really shouldn't happen since channel is holding a reference */
ReleaseSRWLockShared(&gConsoleLock);
return 0; /* EOF */
}
AcquireSRWLockExclusive(&handleInfoPtr->lock);
ReleaseSRWLockShared(&gConsoleLock); /* AFTER acquiring handleInfoPtr->lock */
while (1) {
numRead = RingBufferOut(&handleInfoPtr->buffer, bufPtr, bufSize, 1);
/*
* Note: even if channel is closed or has an error, as long there is
* buffered data, we will pass it up.
*/
if (numRead != 0) {
break;
}
/*
* No data available.
* - If an error was recorded, generate that and reset it.
* - If EOF, indicate as much. It is up to the application to close
* the channel.
* - Otherwise, if non-blocking return EAGAIN or wait for more data.
*/
if (handleInfoPtr->lastError != 0) {
if (handleInfoPtr->lastError == ERROR_INVALID_HANDLE) {
numRead = 0; /* Treat as EOF */
} else {
Tcl_WinConvertError(handleInfoPtr->lastError);
handleInfoPtr->lastError = 0;
*errorCode = Tcl_GetErrno();
numRead = -1;
}
break;
}
if (handleInfoPtr->console == INVALID_HANDLE_VALUE) {
/* EOF - break with numRead == 0 */
chanInfoPtr->handle = INVALID_HANDLE_VALUE;
break;
}
/* For async, tell caller we are blocked */
if (chanInfoPtr->flags & CONSOLE_ASYNC) {
*errorCode = EWOULDBLOCK;
numRead = -1;
break;
}
/*
* Blocking read. Just get data from directly from console. There
* is a small complication in that we can only read even number
* of bytes (wide-character API) and the destination buffer should be
* WCHAR aligned. If either condition is not met, we defer to the
* reader thread which handles these case rather than dealing with
* them here (which is a little trickier than it might sound.)
*/
if ((1 & (ptrdiff_t)bufPtr) == 0 /* aligned buffer */
&& bufSize > 1 /* Not single byte read */
) {
DWORD lastError;
RingSizeT numChars;
ReleaseSRWLockExclusive(&handleInfoPtr->lock);
lastError = ReadConsoleChars(chanInfoPtr->handle,
(WCHAR *)bufPtr,
bufSize / sizeof(WCHAR),
&numChars);
/* NOTE lock released so DON'T break. Return instead */
if (lastError != ERROR_SUCCESS) {
Tcl_WinConvertError(lastError);
*errorCode = Tcl_GetErrno();
return -1;
} else if (numChars > 0) {
/* Successfully read something. */
return numChars * sizeof(WCHAR);
} else {
/*
* Ctrl-C/Ctrl-Brk interrupt. Loop around to retry.
* We have to reacquire the lock. No worried about handleInfoPtr
* having gone away since the channel holds a reference.
*/
AcquireSRWLockExclusive(&handleInfoPtr->lock);
continue;
}
}
/*
* Deferring blocking read to reader thread.
* Release the lock and sleep. Note that because the channel
* holds a reference count on handleInfoPtr, it will not
* be deallocated while the lock is released.
*/
handleInfoPtr->flags |= CONSOLE_DATA_AWAITED;
WakeConditionVariable(&handleInfoPtr->consoleThreadCV);
if (!SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV,
&handleInfoPtr->lock,
INFINITE,
0)) {
Tcl_WinConvertError(GetLastError());
*errorCode = Tcl_GetErrno();
numRead = -1;
break;
}
/* Lock is reacquired, loop back to try again */
}
/* We read data. Ask for more if either async or watching for reads */
if ((chanInfoPtr->flags & CONSOLE_ASYNC)
|| (chanInfoPtr->watchMask & TCL_READABLE)) {
handleInfoPtr->flags |= CONSOLE_DATA_AWAITED;
WakeConditionVariable(&handleInfoPtr->consoleThreadCV);
}
ReleaseSRWLockExclusive(&handleInfoPtr->lock);
return numRead;
}
/*
*----------------------------------------------------------------------
*
* ConsoleOutputProc --
*
* Writes the given output on the IO channel. Returns count of how many
* characters were actually written, and an error indication.
*
* Results:
* A count of how many characters were written is returned and an error
* indication is returned in an output argument.
*
* Side effects:
* Writes output on the actual channel.
*
*----------------------------------------------------------------------
*/
static int
ConsoleOutputProc(
void *instanceData, /* Console state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
ConsoleHandleInfo *handleInfoPtr;
RingSizeT numWritten;
*errorCode = 0;
if (chanInfoPtr->handle == INVALID_HANDLE_VALUE) {
/* Some other thread would have *previously* closed the stdio handle */
*errorCode = EPIPE;
return -1;
}
AcquireSRWLockShared(&gConsoleLock);
handleInfoPtr = FindConsoleInfo(chanInfoPtr);
if (handleInfoPtr == NULL) {
/* Really shouldn't happen since channel is holding a reference */
*errorCode = EPIPE;
ReleaseSRWLockShared(&gConsoleLock);
return -1;
}
AcquireSRWLockExclusive(&handleInfoPtr->lock);
ReleaseSRWLockShared(&gConsoleLock); /* AFTER acquiring handleInfoPtr->lock */
/* Keep looping until all written. Break out for async and errors */
numWritten = 0;
while (1) {
/* Check for error and closing on every loop. */
if (handleInfoPtr->lastError != 0) {
Tcl_WinConvertError(handleInfoPtr->lastError);
*errorCode = Tcl_GetErrno();
numWritten = -1;
break;
}
if (handleInfoPtr->console == INVALID_HANDLE_VALUE) {
*errorCode = EPIPE;
chanInfoPtr->handle = INVALID_HANDLE_VALUE;
numWritten = -1;
break;
}
/*
* We can either write directly or through the console thread's
* ring buffer. We have to do the latter when
* (1) the operation is async since WriteConsoleChars is always blocking
* (2) when there is already data in the ring buffer because we don't
* want to reorder output from within a thread
* (3) when there are an odd number of bytes since WriteConsole
* takes whole WCHARs
* (4) when the pointer is not aligned on WCHAR
* The ring buffer deals with cases (3) and (4). It would be harder
* to duplicate that here.
*/
if ((chanInfoPtr->flags & CONSOLE_ASYNC) /* Case (1) */
|| RingBufferLength(&handleInfoPtr->buffer) != 0 /* Case (2) */
|| (toWrite & 1) != 0 /* Case (3) */
|| (PTR2INT(buf) & 1) != 0 /* Case (4) */
) {
numWritten += RingBufferIn(&handleInfoPtr->buffer,
numWritten + buf,
toWrite - numWritten,
1);
if (numWritten == toWrite || chanInfoPtr->flags & CONSOLE_ASYNC) {
/* All done or async, just accept whatever was written */
break;
}
/*
* Release the lock and sleep. Note that because the channel
* holds a reference count on handleInfoPtr, it will not
* be deallocated while the lock is released.
*/
WakeConditionVariable(&handleInfoPtr->consoleThreadCV);
if (!SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV,
&handleInfoPtr->lock,
INFINITE,
0)) {
/* Report the error */
Tcl_WinConvertError(GetLastError());
*errorCode = Tcl_GetErrno();
numWritten = -1;
break;
}
} else {
/* Direct output */
DWORD winStatus;
HANDLE consoleHandle = handleInfoPtr->console;
/* Unlock before blocking in WriteConsole */
ReleaseSRWLockExclusive(&handleInfoPtr->lock);
/* UNLOCKED so return, DON'T break out of loop as it will unlock again! */
winStatus = WriteConsoleChars(consoleHandle,
(WCHAR *)buf,
toWrite / sizeof(WCHAR),
&numWritten);
if (winStatus == ERROR_SUCCESS) {
return numWritten * sizeof(WCHAR);
} else {
Tcl_WinConvertError(winStatus);
*errorCode = Tcl_GetErrno();
return -1;
}
}
/* Lock must have been reacquired before continuing loop */
}
WakeConditionVariable(&handleInfoPtr->consoleThreadCV);
ReleaseSRWLockExclusive(&handleInfoPtr->lock);
return numWritten;
}
/*
*----------------------------------------------------------------------
*
* ConsoleEventProc --
*
|
| ︙ | ︙ | |||
842 843 844 845 846 847 848 |
static int
ConsoleEventProc(
Tcl_Event *evPtr, /* Event to service. */
int flags) /* Flags that indicate what events to handle,
* such as TCL_FILE_EVENTS. */
{
ConsoleEvent *consoleEvPtr = (ConsoleEvent *) evPtr;
| | > | < > < | | | < < < < < < < < < > > > > | | < | < | < < > | | > > > > | < < | | | | > | < | | > > | > | > > > > > > | | > > > > > > > > > > > > > > > | 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 |
static int
ConsoleEventProc(
Tcl_Event *evPtr, /* Event to service. */
int flags) /* Flags that indicate what events to handle,
* such as TCL_FILE_EVENTS. */
{
ConsoleEvent *consoleEvPtr = (ConsoleEvent *) evPtr;
ConsoleChannelInfo *chanInfoPtr;
int freeChannel;
int mask = 0;
if (!(flags & TCL_FILE_EVENTS)) {
return 0;
}
chanInfoPtr = consoleEvPtr->chanInfoPtr;
/*
* We know chanInfoPtr is valid because its reference count would have
* been incremented when the event was queued. The corresponding release
* happens in this function.
*/
/*
* Global lock used for chanInfoPtr. A read (shared) lock suffices
* because all access is within the channel owning thread with the
* exception of watchers which is a read-only access. See comments
* to ConsoleChannelInfo.
*/
AcquireSRWLockShared(&gConsoleLock);
chanInfoPtr->flags &= ~CONSOLE_EVENT_QUEUED;
/*
* Only handle the event if the Tcl channel has not gone away AND is
* still owned by this thread AND is still watching events.
*/
if (chanInfoPtr->channel && chanInfoPtr->threadId == Tcl_GetCurrentThread()
&& (chanInfoPtr->watchMask & (TCL_READABLE|TCL_WRITABLE))) {
ConsoleHandleInfo *handleInfoPtr;
handleInfoPtr = FindConsoleInfo(chanInfoPtr);
if (handleInfoPtr == NULL) {
/* Console was closed. EOF->read event only (not write) */
if (chanInfoPtr->watchMask & TCL_READABLE) {
mask = TCL_READABLE;
}
} else {
AcquireSRWLockShared(&handleInfoPtr->lock);
/* Remember at most one of READABLE, WRITABLE set */
if ((chanInfoPtr->watchMask & TCL_READABLE)
&& RingBufferLength(&handleInfoPtr->buffer)) {
mask = TCL_READABLE;
} else if ((chanInfoPtr->watchMask & TCL_WRITABLE)
&& RingBufferHasFreeSpace(&handleInfoPtr->buffer)) {
/* Generate write event space available */
mask = TCL_WRITABLE;
}
ReleaseSRWLockShared(&handleInfoPtr->lock);
}
}
/*
* Tcl_NotifyChannel can recurse through the file event callback so need
* to release locks first. Our reference still holds so no danger of
* chanInfoPtr being deallocated if the callback closes the channel.
*/
ReleaseSRWLockShared(&gConsoleLock);
if (mask) {
Tcl_NotifyChannel(chanInfoPtr->channel, mask);
/* Note: chanInfoPtr ref count may have changed */
}
/* No need to lock - see comments earlier */
/* Remove the reference to the channel from event record */
if (chanInfoPtr->numRefs > 1) {
chanInfoPtr->numRefs -= 1;
freeChannel = 0;
} else {
assert(chanInfoPtr->channel == NULL);
freeChannel = 1;
}
if (freeChannel) {
Tcl_Free(chanInfoPtr);
}
return 1;
}
/*
*----------------------------------------------------------------------
*
* ConsoleWatchProc --
|
| ︙ | ︙ | |||
923 924 925 926 927 928 929 | * None. * *---------------------------------------------------------------------- */ static void ConsoleWatchProc( | | | | | | | | < | | > > | > | > > > > > > > > > > > > | > > < | < > | | | | > | 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 |
* None.
*
*----------------------------------------------------------------------
*/
static void
ConsoleWatchProc(
void *instanceData, /* Console state. */
int newMask) /* What events to watch for, one of
* of TCL_READABLE, TCL_WRITABLE
*/
{
ConsoleChannelInfo **nextPtrPtr, *ptr;
ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
int oldMask = chanInfoPtr->watchMask;
/*
* Since most of the work is handled by the background threads, we just
* need to update the watchMask and then force the notifier to poll once.
*/
chanInfoPtr->watchMask = newMask & chanInfoPtr->permissions;
if (chanInfoPtr->watchMask) {
Tcl_Time blockTime = { 0, 0 };
if (!oldMask) {
AcquireSRWLockExclusive(&gConsoleLock);
/* Add to list of watched channels */
chanInfoPtr->nextWatchingChannelPtr = gWatchingChannelList;
gWatchingChannelList = chanInfoPtr;
/*
* For read channels, need to tell the console reader thread
* that we are looking for data since it will not do reads until
* it knows someone is awaiting.
*/
ConsoleHandleInfo *handleInfoPtr;
handleInfoPtr = FindConsoleInfo(chanInfoPtr);
if (handleInfoPtr) {
AcquireSRWLockExclusive(&handleInfoPtr->lock);
handleInfoPtr->flags |= CONSOLE_DATA_AWAITED;
WakeConditionVariable(&handleInfoPtr->consoleThreadCV);
ReleaseSRWLockExclusive(&handleInfoPtr->lock);
}
ReleaseSRWLockExclusive(&gConsoleLock);
}
Tcl_SetMaxBlockTime(&blockTime);
} else if (oldMask) {
/* Remove from list of watched channels */
AcquireSRWLockExclusive(&gConsoleLock);
for (nextPtrPtr = &gWatchingChannelList, ptr = *nextPtrPtr;
ptr != NULL;
nextPtrPtr = &ptr->nextWatchingChannelPtr, ptr = *nextPtrPtr) {
if (chanInfoPtr == ptr) {
*nextPtrPtr = ptr->nextWatchingChannelPtr;
break;
}
}
ReleaseSRWLockExclusive(&gConsoleLock);
}
}
/*
*----------------------------------------------------------------------
*
* ConsoleGetHandleProc --
|
| ︙ | ︙ | |||
983 984 985 986 987 988 989 | * None. * *---------------------------------------------------------------------- */ static int ConsoleGetHandleProc( | | | | > > > | | | | < < | < < < < < < < < < < < < < < < > | > > > > > | > | > > > > > | < | < < < < < | | | < < < < < < < | < < > | | > | | | < | < < < | < < < | < < < | < < < < | < | < < < < | < < | | < | < < < < | < < < < | < > | < < < | < < | | < | | < < > > > > > | > > > > > | > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > | | > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > | > > | > > > > > > > > > > > > > > < < < < | | < < < < | | < < < < | < < | < < < < < | < < < | < | < | < < < | < | < < < | | < | < < | < < < | < < | < > | > > > > > > > > | > > > > | > > > | > | > > > > | | > < | > > > > > > | > > | > > > | | > | < | | > > > > > > | > | < < | < < > > | < | < | < < | > > > > > > > | | > > > > > > | > > | < > > | | | > | > > > | | > | < | > > | > | | < | > > > > > > > | > > > > > > > | < | | | > < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | | < | > > | | < < > | | | | | < < | | < < < | < | | | > | > > > > | | > > > > > > | > | > > > > > | > > | > > > > > > > < > > > > > > > > > > > | < | | | > | > > > | | | | | | | < < < < < < | < < < < < < < < < | < | < | < < | | | | > | | | < | | < < < < < < < < < | | 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 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 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 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 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 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 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 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 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 2327 2328 |
* None.
*
*----------------------------------------------------------------------
*/
static int
ConsoleGetHandleProc(
void *instanceData, /* The console state. */
TCL_UNUSED(int) /*direction*/,
void **handlePtr) /* Where to store the handle. */
{
ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
if (chanInfoPtr->handle == INVALID_HANDLE_VALUE) {
return TCL_ERROR;
} else {
*handlePtr = chanInfoPtr->handle;
return TCL_OK;
}
}
/*
*------------------------------------------------------------------------
*
* ConsoleDataAvailable --
*
* Checks if there is data in the console input queue.
*
* Results:
* Returns 1 if the input queue has data, -1 on error else 0 if empty.
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
static int
ConsoleDataAvailable (HANDLE consoleHandle)
{
INPUT_RECORD input[10];
DWORD count;
DWORD i;
/*
* Need at least one keyboard event.
*/
if (PeekConsoleInputW(
consoleHandle, input, sizeof(input) / sizeof(input[0]), &count)
== FALSE) {
return -1;
}
/*
* Even if windows size and mouse events are disabled, can still have
* events other than keyboard, like focus events. Look for at least one
* keydown event because a trailing LF keyup is always present from the
* last input. However, if our buffer is full, assume there is a key
* down somewhere in the unread buffer. I suppose we could expand the
* buffer but not worth...
*/
if (count == (sizeof(input)/sizeof(input[0])))
return 1;
for (i = 0; i < count; ++i) {
if (input[i].EventType == KEY_EVENT
&& input[i].Event.KeyEvent.bKeyDown) {
return 1;
}
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* ConsoleReaderThread --
*
* This function runs in a separate thread and waits for input to become
* available on a console.
*
* Results:
* Always 0.
*
* Side effects:
* Signals the main thread when input become available.
*
*----------------------------------------------------------------------
*/
static DWORD WINAPI
ConsoleReaderThread(
LPVOID arg)
{
ConsoleHandleInfo *handleInfoPtr = (ConsoleHandleInfo *) arg;
ConsoleHandleInfo **iterator;
char inputChars[200]; /* Temporary buffer */
RingSizeT inputLen = 0;
RingSizeT inputOffset = 0;
/*
* Keep looping until one of the following happens.
* - there are no more channels listening on the console
* - the console handle has been closed
*/
/* This thread is holding a reference so pointer is safe */
AcquireSRWLockExclusive(&handleInfoPtr->lock);
while (1) {
if (handleInfoPtr->numRefs == 1) {
/*
* Sole reference. That's this thread. Exit since no clients
* and no way for a thread to attach to a console after process
* start.
*/
break;
}
/*
* Shared buffer has no data. If we have some in our private buffer
* copy that. Else check if there has been an error. In both cases
* notify the interp threads.
*/
if (inputLen > 0 || handleInfoPtr->lastError != 0) {
HANDLE consoleHandle;
if (inputLen > 0) {
/* Private buffer has data. Copy it over. */
RingSizeT nStored;
assert((inputLen - inputOffset) > 0);
nStored = RingBufferIn(&handleInfoPtr->buffer,
inputOffset + inputChars,
inputLen - inputOffset,
1);
inputOffset += nStored;
if (inputOffset == inputLen) {
/* Temp buffer now empty */
inputOffset = 0;
inputLen = 0;
}
} else {
/*
* On error, nothing but inform caller and wait
* We do not want to exit until there are no client interps.
*/
}
/*
* Wake up any threads waiting either synchronously or
* asynchronously. Since we are providing data, turn off the
* AWAITED flag. If the data provided is not sufficient the
* clients will request again. Note we have to wake up ALL
* awaiting threads, not just one, so they can all reissue
* requests if needed. (In a properly designed app, at most one
* thread should be reading standard input but...)
*/
handleInfoPtr->flags &= ~CONSOLE_DATA_AWAITED;
/* Wake synchronous channels */
WakeAllConditionVariable(&handleInfoPtr->interpThreadCV);
/*
* Wake up async channels registered for file events. Note in
* order to follow the locking hierarchy, we need to release
* handleInfoPtr->lock before calling NudgeWatchers.
*/
consoleHandle = handleInfoPtr->console;
ReleaseSRWLockExclusive(&handleInfoPtr->lock);
NudgeWatchers(consoleHandle);
AcquireSRWLockExclusive(&handleInfoPtr->lock);
/*
* Loop back to recheck for exit conditions changes while the
* the lock was not held.
*/
continue;
}
/*
* Both shared buffer and private buffer are empty. Need to go get
* data from console but do not want to read ahead because the
* interp thread might change the read mode, e.g. turning off echo
* for password input. So only do so if at least one interpreter has
* requested data.
*/
if ((handleInfoPtr->flags & CONSOLE_DATA_AWAITED)
&& ConsoleDataAvailable(handleInfoPtr->console)) {
DWORD error;
/* Do not hold the lock while blocked in console */
ReleaseSRWLockExclusive(&handleInfoPtr->lock);
/*
* Note - the temporary buffer serves two purposes. It
*/
error = ReadConsoleChars(handleInfoPtr->console,
(WCHAR *)inputChars,
sizeof(inputChars) / sizeof(WCHAR),
&inputLen);
AcquireSRWLockExclusive(&handleInfoPtr->lock);
if (error == 0) {
inputLen *= sizeof(WCHAR);
} else {
/*
* We only store the last error. It is up to channel
* handlers whether to close or not in case of errors.
*/
handleInfoPtr->lastError = error;
if (handleInfoPtr->lastError == ERROR_INVALID_HANDLE) {
handleInfoPtr->console = INVALID_HANDLE_VALUE;
}
}
} else {
/*
* Either no one was asking for data, or no data was available.
* In the former case, wait until someone wakes us asking for
* data. In the latter case, there is no alternative but to
* poll since ReadConsole does not support async operation.
* So sleep for a short while and loop back to retry.
*/
DWORD sleepTime;
sleepTime =
handleInfoPtr->flags & CONSOLE_DATA_AWAITED ? 50 : INFINITE;
SleepConditionVariableSRW(&handleInfoPtr->consoleThreadCV,
&handleInfoPtr->lock,
sleepTime,
0);
}
/* Loop again to check for exit or wait for readers to wake us */
}
/*
* Exiting:
* - remove the console from global list
* - close the handle if still valid
* - release the structure
* Note there is not need to check for any watchers because we only
* exit when there are no channels open to this console.
*/
ReleaseSRWLockExclusive(&handleInfoPtr->lock);
AcquireSRWLockExclusive(&gConsoleLock); /* Modifying - exclusive lock */
for (iterator = &gConsoleHandleInfoList; *iterator;
iterator = &(*iterator)->nextPtr) {
if (*iterator == handleInfoPtr) {
*iterator = handleInfoPtr->nextPtr;
break;
}
}
ReleaseSRWLockExclusive(&gConsoleLock);
/* No need for relocking - no other thread should have access to it now */
RingBufferClear(&handleInfoPtr->buffer);
if (handleInfoPtr->console != INVALID_HANDLE_VALUE
&& handleInfoPtr->lastError != ERROR_INVALID_HANDLE) {
SetConsoleMode(handleInfoPtr->console, handleInfoPtr->initMode);
/*
* NOTE: we do not call CloseHandle(handleInfoPtr->console) here.
* As per the GetStdHandle documentation, it need not be closed.
* Other components may be directly using it. Note however that
* an explicit chan close script command does close the handle
* for all threads.
*/
}
Tcl_Free(handleInfoPtr);
return 0;
}
/*
*----------------------------------------------------------------------
*
* ConsoleWriterThread --
*
* This function runs in a separate thread and writes data onto a
* console.
*
* Results:
* Always returns 0.
*
* Side effects:
* Signals the main thread when an output operation is completed.
*
*----------------------------------------------------------------------
*/
static DWORD WINAPI
ConsoleWriterThread(LPVOID arg)
{
ConsoleHandleInfo *handleInfoPtr = (ConsoleHandleInfo *) arg;
ConsoleHandleInfo **iterator;
BOOL success;
RingSizeT numBytes;
/*
* This buffer size has no relation really with the size of the shared
* buffer. Could be bigger or smaller. Make larger as multiple threads
* could potentially be writing to it.
*/
char buffer[2*CONSOLE_BUFFER_SIZE];
/*
* Keep looping until one of the following happens.
*
* - there are not more channels listening on the console
* - the console handle has been closed
*
* On each iteration,
* - if the channel buffer is empty, wait for some channel writer to write
* - if there is data in our buffer, write it to the console
*/
/* This thread is holding a reference so pointer is safe */
AcquireSRWLockExclusive(&handleInfoPtr->lock);
while (1) {
/* handleInfoPtr->lock must be held on entry to loop */
int offset;
HANDLE consoleHandle;
/*
* Sadly, we need to do another copy because do not want to hold
* a lock on handleInfoPtr->buffer while calling WriteConsole as that
* might block. Also, we only want to copy an integral number of
* WCHAR's, i.e. even number of chars so do some length checks up
* front.
*/
numBytes = RingBufferLength(&handleInfoPtr->buffer);
numBytes &= ~1; /* Copy integral number of WCHARs -> even number of bytes */
if (numBytes == 0) {
/* No data to write */
if (handleInfoPtr->numRefs == 1) {
/*
* Sole reference. That's this thread. Exit since no clients
* and no buffered output.
*/
break;
}
/* Wake up any threads waiting synchronously. */
WakeConditionVariable(&handleInfoPtr->interpThreadCV);
success = SleepConditionVariableSRW(&handleInfoPtr->consoleThreadCV,
&handleInfoPtr->lock,
INFINITE,
0);
/* Note: lock has been acquired again! */
if (!success && GetLastError() != ERROR_TIMEOUT) {
/* TODO - what can be done? Should not happen */
/* For now keep going */
}
continue;
}
/* We have data to write */
if ((size_t)numBytes > (sizeof(buffer) / sizeof(buffer[0]))) {
numBytes = sizeof(buffer);
}
/* No need to check result, we already checked length bytes available */
RingBufferOut(&handleInfoPtr->buffer, buffer, numBytes, 0);
consoleHandle = handleInfoPtr->console;
WakeConditionVariable(&handleInfoPtr->interpThreadCV);
ReleaseSRWLockExclusive(&handleInfoPtr->lock);
offset = 0;
while (numBytes > 0) {
RingSizeT numWChars = numBytes / sizeof(WCHAR);
DWORD status;
status = WriteConsoleChars(handleInfoPtr->console,
(WCHAR *)(offset + buffer),
numWChars,
&numWChars);
if (status != 0) {
/* Only overwrite if no previous error */
if (handleInfoPtr->lastError == 0) {
handleInfoPtr->lastError = status;
}
if (status == ERROR_INVALID_HANDLE) {
handleInfoPtr->console = INVALID_HANDLE_VALUE;
}
/* Assume this write is done but keep looping in case
* it is a transient error. Not sure just closing handle
* and exiting thread is a good idea until all references
* from interp threads are gone.
*/
break;
}
numBytes -= numWChars * sizeof(WCHAR);
offset += numWChars * sizeof(WCHAR);
}
/* Wake up any threads waiting synchronously. */
WakeConditionVariable(&handleInfoPtr->interpThreadCV);
/*
* Wake up all channels registered for file events. Note in
* order to follow the locking hierarchy, we cannot hold any locks
* when calling NudgeWatchers.
*/
NudgeWatchers(consoleHandle);
AcquireSRWLockExclusive(&handleInfoPtr->lock);
}
/*
* Exiting:
* - remove the console from global list
* - release the structure
* NOTE: we do not call CloseHandle(handleInfoPtr->console) here.
* As per the GetStdHandle documentation, it need not be closed.
* Other components may be directly using it. Note however that
* an explicit chan close script command does close the handle
* for all threads.
*/
ReleaseSRWLockExclusive(&handleInfoPtr->lock);
AcquireSRWLockExclusive(&gConsoleLock); /* Modifying - exclusive lock */
for (iterator = &gConsoleHandleInfoList; *iterator;
iterator = &(*iterator)->nextPtr) {
if (*iterator == handleInfoPtr) {
*iterator = handleInfoPtr->nextPtr;
break;
}
}
ReleaseSRWLockExclusive(&gConsoleLock);
RingBufferClear(&handleInfoPtr->buffer);
Tcl_Free(handleInfoPtr);
return 0;
}
/*
*------------------------------------------------------------------------
*
* AllocateConsoleHandleInfo --
*
* Allocates a ConsoleHandleInfo for the passed console handle. As
* a side effect starts a console thread to handle i/o on the handle.
*
* Important: Caller must be holding an EXCLUSIVE lock on gConsoleLock
* when calling this function. The lock continues to be held on return.
*
* Results:
* Pointer to an unlocked ConsoleHandleInfo structure. The reference
* count on the structure is 1. This corresponds to the common reference
* from the console thread and the gConsoleHandleInfoList. Returns NULL
* on error.
*
* Side effects:
* A console reader or writer thread is started. The returned structure
* is placed on the active console handler list gConsoleHandleInfoList.
*
*------------------------------------------------------------------------
*/
static ConsoleHandleInfo *
AllocateConsoleHandleInfo(
HANDLE consoleHandle,
int permissions) /* TCL_READABLE or TCL_WRITABLE */
{
ConsoleHandleInfo *handleInfoPtr;
DWORD consoleMode;
handleInfoPtr = (ConsoleHandleInfo *)Tcl_Alloc(sizeof(*handleInfoPtr));
memset(handleInfoPtr, 0, sizeof(*handleInfoPtr));
memset(handleInfoPtr, 0, sizeof(*handleInfoPtr));
handleInfoPtr->console = consoleHandle;
InitializeSRWLock(&handleInfoPtr->lock);
InitializeConditionVariable(&handleInfoPtr->consoleThreadCV);
InitializeConditionVariable(&handleInfoPtr->interpThreadCV);
RingBufferInit(&handleInfoPtr->buffer, CONSOLE_BUFFER_SIZE);
handleInfoPtr->lastError = 0;
handleInfoPtr->permissions = permissions;
handleInfoPtr->numRefs = 1; /* See function header */
if (permissions == TCL_READABLE) {
GetConsoleMode(consoleHandle, &handleInfoPtr->initMode);
consoleMode = handleInfoPtr->initMode;
consoleMode &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT);
consoleMode |= ENABLE_LINE_INPUT;
SetConsoleMode(consoleHandle, consoleMode);
}
handleInfoPtr->consoleThread = CreateThread(
NULL, /* default security descriptor */
2*CONSOLE_BUFFER_SIZE, /* Stack size - gets rounded up to granularity */
permissions == TCL_READABLE ? ConsoleReaderThread : ConsoleWriterThread,
handleInfoPtr, /* Pass to thread */
0, /* Flags - no special cases */
NULL); /* Don't care about thread id */
if (handleInfoPtr->consoleThread == NULL) {
/* Note - SRWLock and condition variables do not need finalization */
RingBufferClear(&handleInfoPtr->buffer);
Tcl_Free(handleInfoPtr);
return NULL;
}
/* Chain onto global list */
handleInfoPtr->nextPtr = gConsoleHandleInfoList;
gConsoleHandleInfoList = handleInfoPtr;
return handleInfoPtr;
}
/*
*------------------------------------------------------------------------
*
* FindConsoleInfo --
*
* Finds the ConsoleHandleInfo record for a given ConsoleChannelInfo.
* The found record must match the console handle. It is the caller's
* responsibility to check the permissions (read/write) in the returned
* ConsoleHandleInfo match permissions in chanInfoPtr. This function does
* not check that.
*
* Important: Caller must be holding an shared or exclusive lock on
* gConsoleMutex. That ensures the returned pointer stays valid on
* return without risk of deallocation by other threads.
*
* Results:
* Pointer to the found ConsoleHandleInfo or NULL if not found
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
static ConsoleHandleInfo *
FindConsoleInfo(const ConsoleChannelInfo *chanInfoPtr)
{
ConsoleHandleInfo *handleInfoPtr;
for (handleInfoPtr = gConsoleHandleInfoList; handleInfoPtr; handleInfoPtr = handleInfoPtr->nextPtr) {
if (handleInfoPtr->console == chanInfoPtr->handle) {
return handleInfoPtr;
}
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* TclWinOpenConsoleChannel --
*
* Constructs a Console channel for the specified standard OS handle.
* This is a helper function to break up the construction of channels
* into File, Console, or Serial.
*
* Results:
* Returns the new channel, or NULL.
*
* Side effects:
* May open the channel.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
TclWinOpenConsoleChannel(
HANDLE handle,
char *channelName,
int permissions)
{
ConsoleChannelInfo *chanInfoPtr;
ConsoleHandleInfo *handleInfoPtr;
/* A console handle can either be input or output, not both */
if (permissions != TCL_READABLE && permissions != TCL_WRITABLE) {
return NULL;
}
ConsoleInit();
chanInfoPtr = (ConsoleChannelInfo *)Tcl_Alloc(sizeof(*chanInfoPtr));
memset(chanInfoPtr, 0, sizeof(*chanInfoPtr));
chanInfoPtr->permissions = permissions;
chanInfoPtr->handle = handle;
chanInfoPtr->channel = (Tcl_Channel) NULL;
chanInfoPtr->threadId = Tcl_GetCurrentThread();
/*
* Use the pointer for the name of the result channel. This keeps the
* channel names unique, since some may share handles (stdin/stdout/stderr
* for instance).
*/
sprintf(channelName, "file%" TCL_Z_MODIFIER "x", (size_t) chanInfoPtr);
if (permissions & TCL_READABLE) {
/*
* Make sure the console input buffer is ready for only character
* input notifications and the buffer is set for line buffering. IOW,
* we only want to catch when complete lines are ready for reading.
*/
chanInfoPtr->flags |= CONSOLE_READ_OPS;
GetConsoleMode(handle, &chanInfoPtr->initMode);
#ifdef OBSOLETE
/* Why was priority being set on console input? Code smell */
SetThreadPriority(infoPtr->reader.thread, THREAD_PRIORITY_HIGHEST);
#endif
} else {
/* Already checked permissions is WRITABLE if not READABLE */
/* TODO - enable ansi escape processing? */
}
/*
* Global lock but that's ok. See comments top of file. Allocations
* will happen only a few times in the life of a process and that too
* generally at start up where only one thread is active.
*/
AcquireSRWLockExclusive(&gConsoleLock); /*Allocate needs exclusive lock */
handleInfoPtr = FindConsoleInfo(chanInfoPtr);
if (handleInfoPtr == NULL) {
/* Not found. Allocate one */
handleInfoPtr = AllocateConsoleHandleInfo(handle, permissions);
} else {
/* Found. Its direction (read/write) better be the same */
if (handleInfoPtr->permissions != permissions) {
handleInfoPtr = NULL;
}
}
if (handleInfoPtr == NULL) {
ReleaseSRWLockExclusive(&gConsoleLock);
if (permissions == TCL_READABLE) {
SetConsoleMode(handle, chanInfoPtr->initMode);
}
Tcl_Free(chanInfoPtr);
return NULL;
}
/*
* There is effectively a reference to this structure from the Tcl
* channel subsystem. So record that. This reference will be dropped
* when the Tcl channel is closed.
*/
chanInfoPtr->numRefs = 1;
/*
* Need to keep track of number of referencing channels for closing.
* The pointer is safe since there is a reference held to it from
* gConsoleHandleInfoList but still need to lock the structure itself
*/
AcquireSRWLockExclusive(&handleInfoPtr->lock);
handleInfoPtr->numRefs += 1;
ReleaseSRWLockExclusive(&handleInfoPtr->lock);
ReleaseSRWLockExclusive(&gConsoleLock);
/* Note Tcl_CreateChannel never fails other than panic on error */
chanInfoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName,
chanInfoPtr, permissions);
/*
* Consoles have default translation of auto and ^Z eof char, which means
* that a ^Z will be accepted as EOF when reading.
*/
Tcl_SetChannelOption(NULL, chanInfoPtr->channel, "-translation", "auto");
Tcl_SetChannelOption(NULL, chanInfoPtr->channel, "-eofchar", "\032 {}");
Tcl_SetChannelOption(NULL, chanInfoPtr->channel, "-encoding", "utf-16");
return chanInfoPtr->channel;
}
/*
*----------------------------------------------------------------------
*
* ConsoleThreadActionProc --
*
* Insert or remove any thread local refs to this channel.
*
* Results:
* None.
*
* Side effects:
* Changes thread local list of valid channels.
*
*----------------------------------------------------------------------
*/
static void
ConsoleThreadActionProc(
void *instanceData,
int action)
{
ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
/* No need for any locks as no other thread will be writing to it */
if (action == TCL_CHANNEL_THREAD_INSERT) {
ConsoleInit(); /* Needed to set up event source handlers for this thread */
chanInfoPtr->threadId = Tcl_GetCurrentThread();
} else {
chanInfoPtr->threadId = NULL;
}
}
/*
*----------------------------------------------------------------------
*
* ConsoleSetOptionProc --
*
* Sets an option on a channel.
*
* Results:
* A standard Tcl result. Also sets the interp's result on error if
* interp is not NULL.
*
* Side effects:
* May modify an option on a console. Sets Error message if needed (by
* calling Tcl_BadChannelOption).
*
*----------------------------------------------------------------------
*/
static int
ConsoleSetOptionProc(
void *instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Which option to set? */
const char *value) /* New value for option. */
{
ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
int len = strlen(optionName);
int vlen = strlen(value);
/*
* Option -inputmode normal|password|raw
*/
if ((chanInfoPtr->flags & CONSOLE_READ_OPS) && (len > 1) &&
(strncmp(optionName, "-inputmode", len) == 0)) {
DWORD mode;
if (GetConsoleMode(chanInfoPtr->handle, &mode) == 0) {
Tcl_WinConvertError(GetLastError());
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read console mode: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
if (Tcl_UtfNcasecmp(value, "NORMAL", vlen) == 0) {
mode |=
ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT | ENABLE_PROCESSED_INPUT;
} else if (Tcl_UtfNcasecmp(value, "PASSWORD", vlen) == 0) {
mode |= ENABLE_LINE_INPUT|ENABLE_PROCESSED_INPUT;
mode &= ~ENABLE_ECHO_INPUT;
} else if (Tcl_UtfNcasecmp(value, "RAW", vlen) == 0) {
mode &= ~(ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT | ENABLE_PROCESSED_INPUT);
} else if (Tcl_UtfNcasecmp(value, "RESET", vlen) == 0) {
/*
* Reset to the initial mode, whatever that is.
*/
mode = chanInfoPtr->initMode;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad mode \"%s\" for -inputmode: must be"
" normal, password, raw, or reset", value));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
return TCL_ERROR;
}
if (SetConsoleMode(chanInfoPtr->handle, mode) == 0) {
Tcl_WinConvertError(GetLastError());
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't set console mode: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
return TCL_OK;
}
if (chanInfoPtr->flags & CONSOLE_READ_OPS) {
return Tcl_BadChannelOption(interp, optionName, "inputmode");
} else {
return Tcl_BadChannelOption(interp, optionName, "");
}
}
/*
|
| ︙ | ︙ | |||
1553 1554 1555 1556 1557 1558 1559 | * (by calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int ConsoleGetOptionProc( | | | | | < | | | | | | > > | > | | | | > | | | > | | | | | > | > | | | > | | > | > > | | | | 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 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 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 |
* (by calling Tcl_BadChannelOption).
*
*----------------------------------------------------------------------
*/
static int
ConsoleGetOptionProc(
void *instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Option to get. */
Tcl_DString *dsPtr) /* Where to store value(s). */
{
ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
int valid = 0; /* Flag if valid option parsed. */
unsigned int len;
char buf[TCL_INTEGER_SPACE];
if (optionName == NULL) {
len = 0;
} else {
len = strlen(optionName);
}
/*
* Get option -inputmode
*
* This is a great simplification of the underlying reality, but actually
* represents what almost all scripts really want to know.
*/
if (chanInfoPtr->flags & CONSOLE_READ_OPS) {
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-inputmode");
}
if (len==0 || (len>1 && strncmp(optionName, "-inputmode", len)==0)) {
DWORD mode;
valid = 1;
if (GetConsoleMode(chanInfoPtr->handle, &mode) == 0) {
Tcl_WinConvertError(GetLastError());
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read console mode: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
if (mode & ENABLE_LINE_INPUT) {
if (mode & ENABLE_ECHO_INPUT) {
Tcl_DStringAppendElement(dsPtr, "normal");
} else {
Tcl_DStringAppendElement(dsPtr, "password");
}
} else {
Tcl_DStringAppendElement(dsPtr, "raw");
}
}
} else {
/*
* Output channel. Get option -winsize
* Option is readonly and returned by [fconfigure chan -winsize] but not
* returned by [fconfigure chan] without explicit option name.
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-winsize");
}
if (len == 0 || (len > 1 && strncmp(optionName, "-winsize", len) == 0)) {
CONSOLE_SCREEN_BUFFER_INFO consoleInfo;
valid = 1;
if (!GetConsoleScreenBufferInfo(chanInfoPtr->handle,
&consoleInfo)) {
Tcl_WinConvertError(GetLastError());
if (interp != NULL) {
Tcl_SetObjResult(
interp,
Tcl_ObjPrintf("couldn't read console size: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
Tcl_DStringStartSublist(dsPtr);
sprintf(buf,
"%d",
consoleInfo.srWindow.Right - consoleInfo.srWindow.Left + 1);
Tcl_DStringAppendElement(dsPtr, buf);
sprintf(buf,
"%d",
consoleInfo.srWindow.Bottom - consoleInfo.srWindow.Top + 1);
Tcl_DStringAppendElement(dsPtr, buf);
Tcl_DStringEndSublist(dsPtr);
}
}
if (valid) {
return TCL_OK;
}
if (chanInfoPtr->flags & CONSOLE_READ_OPS) {
return Tcl_BadChannelOption(interp, optionName, "inputmode");
} else {
return Tcl_BadChannelOption(interp, optionName, "winsize");
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/tclWinDde.c.
| ︙ | ︙ | |||
1785 1786 1787 1788 1789 1790 1791 |
" defined for use in a safe interp", -1));
Tcl_SetErrorCode(interp, "TCL", "DDE", "SECURITY_CHECK",
NULL);
result = TCL_ERROR;
}
if (result == TCL_OK) {
| | | | 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 |
" defined for use in a safe interp", -1));
Tcl_SetErrorCode(interp, "TCL", "DDE", "SECURITY_CHECK",
NULL);
result = TCL_ERROR;
}
if (result == TCL_OK) {
if (objc == 1) {
objPtr = objv[0];
} else {
objPtr = Tcl_ConcatObj(objc, objv);
}
if (riPtr->handlerPtr != NULL) {
/* add the dde request data to the handler proc list */
/*
*result = Tcl_ListObjReplace(sendInterp, objPtr, 0, 0, 1,
* &(riPtr->handlerPtr));
|
| ︙ | ︙ |
Changes to win/tclWinFCmd.c.
| ︙ | ︙ | |||
305 306 307 308 309 310 311 |
return TCL_ERROR;
}
if (errno == EACCES) {
decode:
if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
WCHAR *nativeSrcRest, *nativeDstRest;
const char **srcArgv, **dstArgv;
| | | | | 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 |
return TCL_ERROR;
}
if (errno == EACCES) {
decode:
if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
WCHAR *nativeSrcRest, *nativeDstRest;
const char **srcArgv, **dstArgv;
size_t size, srcArgc, dstArgc;
WCHAR nativeSrcPath[MAX_PATH];
WCHAR nativeDstPath[MAX_PATH];
Tcl_DString srcString, dstString;
const char *src, *dst;
size = GetFullPathNameW(nativeSrc, MAX_PATH,
nativeSrcPath, &nativeSrcRest);
if ((size == 0) || (size > MAX_PATH)) {
return TCL_ERROR;
}
size = GetFullPathNameW(nativeDst, MAX_PATH,
nativeDstPath, &nativeDstRest);
if ((size == 0) || (size > MAX_PATH)) {
return TCL_ERROR;
}
CharLowerW(nativeSrcPath);
CharLowerW(nativeDstPath);
Tcl_DStringInit(&srcString);
Tcl_DStringInit(&dstString);
src = Tcl_WCharToUtfDString(nativeSrcPath, TCL_INDEX_NONE, &srcString);
dst = Tcl_WCharToUtfDString(nativeDstPath, TCL_INDEX_NONE, &dstString);
/*
* Check whether the destination path is actually inside the
* source path. This is true if the prefix matches, and the next
* character is either end-of-string or a directory separator
*/
|
| ︙ | ︙ | |||
925 926 927 928 929 930 931 |
if (ret != TCL_OK) {
if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normSrcPtr))) {
*errorPtr = srcPathPtr;
} else if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normDestPtr))) {
*errorPtr = destPathPtr;
} else {
| | | 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 |
if (ret != TCL_OK) {
if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normSrcPtr))) {
*errorPtr = srcPathPtr;
} else if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normDestPtr))) {
*errorPtr = destPathPtr;
} else {
*errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), TCL_INDEX_NONE);
}
Tcl_DStringFree(&ds);
Tcl_IncrRefCount(*errorPtr);
}
return ret;
}
|
| ︙ | ︙ | |||
1113 1114 1115 1116 1117 1118 1119 |
}
end:
if (errorPtr != NULL) {
char *p;
Tcl_DStringInit(errorPtr);
| | | 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 |
}
end:
if (errorPtr != NULL) {
char *p;
Tcl_DStringInit(errorPtr);
p = Tcl_WCharToUtfDString(nativePath, TCL_INDEX_NONE, errorPtr);
for (; *p; ++p) {
if (*p == '\\') *p = '/';
}
}
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1328 1329 1330 1331 1332 1333 1334 |
}
end:
if (nativeErrfile != NULL) {
Tcl_WinConvertError(GetLastError());
if (errorPtr != NULL) {
Tcl_DStringInit(errorPtr);
| | | 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 |
}
end:
if (nativeErrfile != NULL) {
Tcl_WinConvertError(GetLastError());
if (errorPtr != NULL) {
Tcl_DStringInit(errorPtr);
Tcl_WCharToUtfDString(nativeErrfile, TCL_INDEX_NONE, errorPtr);
}
result = TCL_ERROR;
}
return result;
}
|
| ︙ | ︙ | |||
1394 1395 1396 1397 1398 1399 1400 |
/*
* There shouldn't be a problem with src, because we already checked it to
* get here.
*/
if (errorPtr != NULL) {
Tcl_DStringInit(errorPtr);
| | | 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 |
/*
* There shouldn't be a problem with src, because we already checked it to
* get here.
*/
if (errorPtr != NULL) {
Tcl_DStringInit(errorPtr);
Tcl_WCharToUtfDString(nativeDst, TCL_INDEX_NONE, errorPtr);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1450 1451 1452 1453 1454 1455 1456 |
return TCL_OK;
}
break;
}
if (errorPtr != NULL) {
Tcl_DStringInit(errorPtr);
| | | 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 |
return TCL_OK;
}
break;
}
if (errorPtr != NULL) {
Tcl_DStringInit(errorPtr);
Tcl_WCharToUtfDString(nativeSrc, TCL_INDEX_NONE, errorPtr);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1591 1592 1593 1594 1595 1596 1597 |
ConvertFileNameFormat(
Tcl_Interp *interp, /* The interp we are using for errors. */
TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file. */
int longShort, /* 0 to short name, 1 to long name. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
| | | 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 |
ConvertFileNameFormat(
Tcl_Interp *interp, /* The interp we are using for errors. */
TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file. */
int longShort, /* 0 to short name, 1 to long name. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
size_t pathc, i;
Tcl_Obj *splitPath;
size_t length;
splitPath = Tcl_FSSplitPath(fileName, &pathc);
if (splitPath == NULL || pathc == 0) {
if (interp != NULL) {
|
| ︙ | ︙ | |||
1708 1709 1710 1711 1712 1713 1714 | * about the second. * * fprintf(stderr, "%d\n", data.w.cAlternateFileName[0]); * fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]); */ Tcl_DStringInit(&dsTemp); | | < < < < < < < < < < | < | | 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 |
* about the second.
*
* fprintf(stderr, "%d\n", data.w.cAlternateFileName[0]);
* fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]);
*/
Tcl_DStringInit(&dsTemp);
Tcl_WCharToUtfDString(nativeName, TCL_INDEX_NONE, &dsTemp);
Tcl_DStringFree(&ds);
tempPath = TclDStringToObj(&dsTemp);
Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath);
FindClose(handle);
}
}
*attributePtrPtr = Tcl_FSJoinPath(splitPath, -1);
if (splitPath != NULL) {
|
| ︙ | ︙ | |||
1948 1949 1950 1951 1952 1953 1954 |
buf[2] = '/';
buf[3] = '\0';
for (i = 0; i < 26; i++) {
buf[0] = (char) ('a' + i);
if (GetVolumeInformationA(buf, NULL, 0, NULL, NULL, NULL, NULL, 0)
|| (GetLastError() == ERROR_NOT_READY)) {
| | | | 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 |
buf[2] = '/';
buf[3] = '\0';
for (i = 0; i < 26; i++) {
buf[0] = (char) ('a' + i);
if (GetVolumeInformationA(buf, NULL, 0, NULL, NULL, NULL, NULL, 0)
|| (GetLastError() == ERROR_NOT_READY)) {
elemPtr = Tcl_NewStringObj(buf, TCL_INDEX_NONE);
Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
}
}
} else {
for (p = buf; *p != '\0'; p += 4) {
p[2] = '/';
elemPtr = Tcl_NewStringObj(p, TCL_INDEX_NONE);
Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
}
}
Tcl_IncrRefCount(resultPtr);
return resultPtr;
}
|
| ︙ | ︙ | |||
2074 2075 2076 2077 2078 2079 2080 |
/*
* We actually made the directory, so we're done! Report what we made back
* as a (clean) Tcl_Obj.
*/
Tcl_DStringInit(&name);
| | | 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 |
/*
* We actually made the directory, so we're done! Report what we made back
* as a (clean) Tcl_Obj.
*/
Tcl_DStringInit(&name);
Tcl_WCharToUtfDString((LPCWSTR) Tcl_DStringValue(&base), TCL_INDEX_NONE, &name);
Tcl_DStringFree(&base);
return TclDStringToObj(&name);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/tclWinFile.c.
| ︙ | ︙ | |||
865 866 867 868 869 870 871 |
WCHAR wName[MAX_PATH];
char name[MAX_PATH * 3];
(void)argv0;
GetModuleFileNameW(NULL, wName, sizeof(wName)/sizeof(WCHAR));
WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL);
TclWinNoBackslash(name);
| | | 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 |
WCHAR wName[MAX_PATH];
char name[MAX_PATH * 3];
(void)argv0;
GetModuleFileNameW(NULL, wName, sizeof(wName)/sizeof(WCHAR));
WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL);
TclWinNoBackslash(name);
TclSetObjNameOfExecutable(Tcl_NewStringObj(name, TCL_INDEX_NONE), NULL);
}
/*
*----------------------------------------------------------------------
*
* TclpMatchInDirectory --
*
|
| ︙ | ︙ | |||
1001 1002 1003 1004 1005 1006 1007 |
if (strpbrk(pattern, "[]\\") == NULL) {
/*
* The pattern is a simple one containing just '*' and/or '?'.
* This means we can get the OS to help us, by passing it the
* pattern.
*/
| | | 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 |
if (strpbrk(pattern, "[]\\") == NULL) {
/*
* The pattern is a simple one containing just '*' and/or '?'.
* This means we can get the OS to help us, by passing it the
* pattern.
*/
dirName = Tcl_DStringAppend(&dsOrig, pattern, TCL_INDEX_NONE);
} else {
dirName = TclDStringAppendLiteral(&dsOrig, "*.*");
}
Tcl_DStringInit(&ds);
native = Tcl_UtfToWCharDString(dirName, -1, &ds);
if ((types == NULL) || (types->type != TCL_GLOB_TYPE_DIR)) {
|
| ︙ | ︙ | |||
1080 1081 1082 1083 1084 1085 1086 |
do {
const char *utfname;
int checkDrive = 0, isDrive;
native = data.cFileName;
attr = data.dwFileAttributes;
Tcl_DStringInit(&ds);
| | | 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 |
do {
const char *utfname;
int checkDrive = 0, isDrive;
native = data.cFileName;
attr = data.dwFileAttributes;
Tcl_DStringInit(&ds);
utfname = Tcl_WCharToUtfDString(native, TCL_INDEX_NONE, &ds);
if (!matchSpecialDots) {
/*
* If it is exactly '.' or '..' then we ignore it.
*/
if ((utfname[0] == '.') && (utfname[1] == '\0'
|
| ︙ | ︙ | |||
1966 1967 1968 1969 1970 1971 1972 |
native = (WCHAR *) buffer;
if ((native[0] != '\0') && (native[1] == ':')
&& (native[2] == '\\') && (native[3] == '\\')) {
native += 2;
}
Tcl_DStringInit(bufferPtr);
| | | 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 |
native = (WCHAR *) buffer;
if ((native[0] != '\0') && (native[1] == ':')
&& (native[2] == '\\') && (native[3] == '\\')) {
native += 2;
}
Tcl_DStringInit(bufferPtr);
Tcl_WCharToUtfDString(native, TCL_INDEX_NONE, bufferPtr);
/*
* Convert to forward slashes for easier use in scripts.
*/
for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
if (*p == '\\') {
|
| ︙ | ︙ | |||
2175 2176 2177 2178 2179 2180 2181 |
Tcl_DString ds;
WCHAR nativeFullPath[MAX_PATH];
WCHAR *nativePart;
const char *fullPath;
GetFullPathNameW(nativePath, MAX_PATH, nativeFullPath, &nativePart);
Tcl_DStringInit(&ds);
| | | 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 |
Tcl_DString ds;
WCHAR nativeFullPath[MAX_PATH];
WCHAR *nativePart;
const char *fullPath;
GetFullPathNameW(nativePath, MAX_PATH, nativeFullPath, &nativePart);
Tcl_DStringInit(&ds);
fullPath = Tcl_WCharToUtfDString(nativeFullPath, TCL_INDEX_NONE, &ds);
if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
const char *p;
DWORD dw;
const WCHAR *nativeVol;
Tcl_DString volString;
|
| ︙ | ︙ | |||
2478 2479 2480 2481 2482 2483 2484 |
if (found == 0) {
return NULL;
} else {
Tcl_DString ds;
Tcl_DStringInit(&ds);
| | | 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 |
if (found == 0) {
return NULL;
} else {
Tcl_DString ds;
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString(volType, TCL_INDEX_NONE, &ds);
return TclDStringToObj(&ds);
}
#undef VOL_BUF_SIZE
}
/*
* This define can be turned on to experiment with a different way of
|
| ︙ | ︙ | |||
2626 2627 2628 2629 2630 2631 2632 | * Tcl_GetStringFromObj(to, &pathLen); * nextCheckpoint = pathLen; * * So, instead we have to start from the beginning. */ nextCheckpoint = 0; | | | 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 |
* Tcl_GetStringFromObj(to, &pathLen);
* nextCheckpoint = pathLen;
*
* So, instead we have to start from the beginning.
*/
nextCheckpoint = 0;
Tcl_AppendToObj(to, currentPathEndPosition, TCL_INDEX_NONE);
/*
* Convert link to forward slashes.
*/
for (path = TclGetString(to); *path != 0; path++) {
if (*path == '\\') {
|
| ︙ | ︙ | |||
2802 2803 2804 2805 2806 2807 2808 | */ Tcl_Obj *tmpPathPtr; size_t length; tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), nextCheckpoint); | | | 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 |
*/
Tcl_Obj *tmpPathPtr;
size_t length;
tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
nextCheckpoint);
Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, TCL_INDEX_NONE);
path = Tcl_GetStringFromObj(tmpPathPtr, &length);
Tcl_SetStringObj(pathPtr, path, length);
Tcl_DecrRefCount(tmpPathPtr);
} else {
/*
* End of string was reached above.
*/
|
| ︙ | ︙ | |||
2875 2876 2877 2878 2879 2880 2881 | * Path of form /foo/bar which is a path in the root directory of the * current volume. */ const char *drive = TclGetString(useThisCwd); absolutePath = Tcl_NewStringObj(drive,2); | | | 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 |
* Path of form /foo/bar which is a path in the root directory of the
* current volume.
*/
const char *drive = TclGetString(useThisCwd);
absolutePath = Tcl_NewStringObj(drive,2);
Tcl_AppendToObj(absolutePath, path, TCL_INDEX_NONE);
Tcl_IncrRefCount(absolutePath);
/*
* We have a refCount on the cwd.
*/
} else {
/*
|
| ︙ | ︙ | |||
2928 2929 2930 2931 2932 2933 2934 | * could use the '_dgetdcwd' Win32 API to get the drive's cwd. */ absolutePath = Tcl_NewStringObj(path, 2); Tcl_AppendToObj(absolutePath, "/", 1); } Tcl_IncrRefCount(absolutePath); | | | 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 |
* could use the '_dgetdcwd' Win32 API to get the drive's cwd.
*/
absolutePath = Tcl_NewStringObj(path, 2);
Tcl_AppendToObj(absolutePath, "/", 1);
}
Tcl_IncrRefCount(absolutePath);
Tcl_AppendToObj(absolutePath, path+2, TCL_INDEX_NONE);
}
*useThisCwdPtr = useThisCwd;
return absolutePath;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
2965 2966 2967 2968 2969 2970 2971 |
{
Tcl_DString ds;
Tcl_Obj *objPtr;
size_t len;
char *copy, *p;
Tcl_DStringInit(&ds);
| | | 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 |
{
Tcl_DString ds;
Tcl_Obj *objPtr;
size_t len;
char *copy, *p;
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString((const WCHAR *) clientData, TCL_INDEX_NONE, &ds);
copy = Tcl_DStringValue(&ds);
len = Tcl_DStringLength(&ds);
/*
* Certain native path representations on Windows have this special prefix
* to indicate that they are to be treated specially. For example
* extremely long paths, or symlinks.
|
| ︙ | ︙ |
Changes to win/tclWinInit.c.
| ︙ | ︙ | |||
194 195 196 197 198 199 200 |
*/
static void
AppendEnvironment(
Tcl_Obj *pathPtr,
const char *lib)
{
| | | 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 |
*/
static void
AppendEnvironment(
Tcl_Obj *pathPtr,
const char *lib)
{
size_t pathc;
WCHAR wBuf[MAX_PATH];
char buf[MAX_PATH * 3];
Tcl_Obj *objPtr;
Tcl_DString ds;
const char **pathv;
char *shortlib;
|
| ︙ | ︙ | |||
229 230 231 232 233 234 235 |
* this is a unicode string.
*/
GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH);
WideCharToMultiByte(CP_UTF8, 0, wBuf, -1, buf, MAX_PATH * 3, NULL, NULL);
if (buf[0] != '\0') {
| | | 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 |
* this is a unicode string.
*/
GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH);
WideCharToMultiByte(CP_UTF8, 0, wBuf, -1, buf, MAX_PATH * 3, NULL, NULL);
if (buf[0] != '\0') {
objPtr = Tcl_NewStringObj(buf, TCL_INDEX_NONE);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
TclWinNoBackslash(buf);
Tcl_SplitPath(buf, &pathc, &pathv);
/*
* The lstrcmpiA() will work even if pathv[pathc-1] is random UTF-8
|
| ︙ | ︙ | |||
253 254 255 256 257 258 259 |
*/
pathv[pathc - 1] = shortlib;
Tcl_DStringInit(&ds);
(void) Tcl_JoinPath(pathc, pathv, &ds);
objPtr = TclDStringToObj(&ds);
} else {
| | | 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 |
*/
pathv[pathc - 1] = shortlib;
Tcl_DStringInit(&ds);
(void) Tcl_JoinPath(pathc, pathv, &ds);
objPtr = TclDStringToObj(&ds);
} else {
objPtr = Tcl_NewStringObj(buf, TCL_INDEX_NONE);
}
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_Free((void *)pathv);
}
}
/*
|
| ︙ | ︙ | |||
499 500 501 502 503 504 505 |
*/
Tcl_DStringInit(&ds);
ptr = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY);
if (ptr == NULL) {
ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY);
if (ptr != NULL) {
| | | > > > > > > | > | 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 |
*/
Tcl_DStringInit(&ds);
ptr = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY);
if (ptr == NULL) {
ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY);
if (ptr != NULL) {
Tcl_DStringAppend(&ds, ptr, TCL_INDEX_NONE);
}
ptr = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY);
if (ptr != NULL) {
Tcl_DStringAppend(&ds, ptr, TCL_INDEX_NONE);
}
if (Tcl_DStringLength(&ds) > 0) {
Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds),
TCL_GLOBAL_ONLY);
} else {
/* None of HOME, HOMEDRIVE, HOMEPATH exists. Try USERPROFILE */
ptr = Tcl_GetVar2(interp, "env", "USERPROFILE", TCL_GLOBAL_ONLY);
if (ptr != NULL && ptr[0]) {
Tcl_SetVar2(interp, "env", "HOME", ptr, TCL_GLOBAL_ONLY);
} else {
/* Last resort */
Tcl_SetVar2(interp, "env", "HOME", "c:\\", TCL_GLOBAL_ONLY);
}
}
}
/*
* Initialize the user name from the environment first, since this is much
* faster than asking the system.
* Note: cchUserNameLen is number of characters including nul terminator.
|
| ︙ | ︙ | |||
590 591 592 593 594 595 596 | /* * Chop the env string off after the equal sign, then Convert the name * to all upper case, so we do not have to convert all the characters * after the equal sign. */ Tcl_DStringInit(&envString); | | | 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 |
/*
* Chop the env string off after the equal sign, then Convert the name
* to all upper case, so we do not have to convert all the characters
* after the equal sign.
*/
Tcl_DStringInit(&envString);
envUpper = Tcl_WCharToUtfDString(env, TCL_INDEX_NONE, &envString);
p1 = strchr(envUpper, '=');
if (p1 == NULL) {
continue;
}
length = p1 - envUpper;
Tcl_DStringSetLength(&envString, length+1);
Tcl_UtfToUpper(envUpper);
|
| ︙ | ︙ |
Changes to win/tclWinLoad.c.
| ︙ | ︙ | |||
110 111 112 113 114 115 116 |
/*
* We choose to only use the error from the second call if the first
* call failed due to the file not being found. Else stick to the
* first error for reporting purposes.
*/
if (firstError == ERROR_MOD_NOT_FOUND ||
| | | > | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 |
/*
* We choose to only use the error from the second call if the first
* call failed due to the file not being found. Else stick to the
* first error for reporting purposes.
*/
if (firstError == ERROR_MOD_NOT_FOUND ||
firstError == ERROR_DLL_NOT_FOUND) {
lastError = GetLastError();
} else {
lastError = firstError;
}
errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ",
TclGetString(pathPtr));
/*
* Check for possible DLL errors. This doesn't work quite right,
* because Windows seems to only return ERROR_MOD_NOT_FOUND for just
|
| ︙ | ︙ | |||
215 216 217 218 219 220 221 |
proc = (void *)GetProcAddress(hInstance, symbol);
if (proc == NULL) {
Tcl_DString ds;
const char *sym2;
Tcl_DStringInit(&ds);
TclDStringAppendLiteral(&ds, "_");
| | | 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 |
proc = (void *)GetProcAddress(hInstance, symbol);
if (proc == NULL) {
Tcl_DString ds;
const char *sym2;
Tcl_DStringInit(&ds);
TclDStringAppendLiteral(&ds, "_");
sym2 = Tcl_DStringAppend(&ds, symbol, TCL_INDEX_NONE);
proc = (void *)GetProcAddress(hInstance, sym2);
Tcl_DStringFree(&ds);
}
if (proc == NULL && interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot find symbol \"%s\"", symbol));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL);
|
| ︙ | ︙ |
Changes to win/tclWinPipe.c.
| ︙ | ︙ | |||
167 168 169 170 171 172 173 | /* * Declarations for functions used only in this file. */ static int ApplicationType(Tcl_Interp *interp, const char *fileName, char *fullName); | | | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 | /* * Declarations for functions used only in this file. */ static int ApplicationType(Tcl_Interp *interp, const char *fileName, char *fullName); static void BuildCommandLine(const char *executable, size_t argc, const char **argv, Tcl_DString *linePtr); static BOOL HasConsole(void); static int PipeBlockModeProc(ClientData instanceData, int mode); static void PipeCheckProc(ClientData clientData, int flags); static int PipeClose2Proc(ClientData instanceData, Tcl_Interp *interp, int flags); static int PipeEventProc(Tcl_Event *evPtr, int flags); |
| ︙ | ︙ | |||
675 676 677 678 679 680 681 | const char *p; int toCopy; /* * Convert the contents from UTF to native encoding */ | | | 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 |
const char *p;
int toCopy;
/*
* Convert the contents from UTF to native encoding
*/
native = Tcl_UtfToExternalDString(NULL, contents, TCL_INDEX_NONE, &dstring);
toCopy = Tcl_DStringLength(&dstring);
for (p = native; toCopy > 0; p++, toCopy--) {
if (*p == '\n') {
length = p - native;
if (length > 0) {
if (!WriteFile(handle, native, length, &result, NULL)) {
|
| ︙ | ︙ | |||
907 908 909 910 911 912 913 |
int
TclpCreateProcess(
Tcl_Interp *interp, /* Interpreter in which to leave errors that
* occurred when creating the child process.
* Error messages from the child process
* itself are sent to errorFile. */
| | | 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 |
int
TclpCreateProcess(
Tcl_Interp *interp, /* Interpreter in which to leave errors that
* occurred when creating the child process.
* Error messages from the child process
* itself are sent to errorFile. */
size_t argc, /* Number of arguments in following array. */
const char **argv, /* Array of argument strings. argv[0] contains
* the name of the executable converted to
* native format (using the
* Tcl_TranslateFileName call). Additional
* arguments have not been converted. */
TclFile inputFile, /* If non-NULL, gives the file to use as input
* for the child process. If inputFile file is
|
| ︙ | ︙ | |||
939 940 941 942 943 944 945 |
Tcl_DString cmdLine; /* Complete command line (WCHAR). */
STARTUPINFOW startInfo;
PROCESS_INFORMATION procInfo;
SECURITY_ATTRIBUTES secAtts;
HANDLE hProcess, h, inputHandle, outputHandle, errorHandle;
char execPath[MAX_PATH * 3];
WinFile *filePtr;
| < | 939 940 941 942 943 944 945 946 947 948 949 950 951 952 |
Tcl_DString cmdLine; /* Complete command line (WCHAR). */
STARTUPINFOW startInfo;
PROCESS_INFORMATION procInfo;
SECURITY_ATTRIBUTES secAtts;
HANDLE hProcess, h, inputHandle, outputHandle, errorHandle;
char execPath[MAX_PATH * 3];
WinFile *filePtr;
PipeInit();
applType = ApplicationType(interp, argv[0], execPath);
if (applType == APPL_NONE) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1282 1283 1284 1285 1286 1287 1288 |
* words, SearchPath will not find the program "a.b.exe" if the arguments
* specified "a.b" and ".exe"). So, first look for the file as it is
* named. Then manually append the extensions, looking for a match.
*/
applType = APPL_NONE;
Tcl_DStringInit(&nameBuf);
| | | | | 1281 1282 1283 1284 1285 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 |
* words, SearchPath will not find the program "a.b.exe" if the arguments
* specified "a.b" and ".exe"). So, first look for the file as it is
* named. Then manually append the extensions, looking for a match.
*/
applType = APPL_NONE;
Tcl_DStringInit(&nameBuf);
Tcl_DStringAppend(&nameBuf, originalName, TCL_INDEX_NONE);
nameLen = Tcl_DStringLength(&nameBuf);
for (i = 0; i < (int) (sizeof(extensions) / sizeof(extensions[0])); i++) {
Tcl_DStringSetLength(&nameBuf, nameLen);
Tcl_DStringAppend(&nameBuf, extensions[i], TCL_INDEX_NONE);
Tcl_DStringInit(&ds);
nativeName = Tcl_UtfToWCharDString(Tcl_DStringValue(&nameBuf),
Tcl_DStringLength(&nameBuf), &ds);
found = SearchPathW(NULL, nativeName, NULL, MAX_PATH,
nativeFullPath, &rest);
Tcl_DStringFree(&ds);
if (found == 0) {
continue;
}
/*
* Ignore matches on directories or data files, return if identified a
* known type.
*/
attr = GetFileAttributesW(nativeFullPath);
if ((attr == 0xFFFFFFFF) || (attr & FILE_ATTRIBUTE_DIRECTORY)) {
continue;
}
Tcl_DStringInit(&ds);
strcpy(fullName, Tcl_WCharToUtfDString(nativeFullPath, TCL_INDEX_NONE, &ds));
Tcl_DStringFree(&ds);
ext = strrchr(fullName, '.');
if ((ext != NULL) &&
(strcasecmp(ext, ".cmd") == 0 || strcasecmp(ext, ".bat") == 0)) {
applType = APPL_DOS;
break;
|
| ︙ | ︙ | |||
1400 1401 1402 1403 1404 1405 1406 | * 16-bit applications. Otherwise the application may not be able to * correctly parse its own command line to separate off the * application name from the arguments. */ GetShortPathNameW(nativeFullPath, nativeFullPath, MAX_PATH); Tcl_DStringInit(&ds); | | | 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 |
* 16-bit applications. Otherwise the application may not be able to
* correctly parse its own command line to separate off the
* application name from the arguments.
*/
GetShortPathNameW(nativeFullPath, nativeFullPath, MAX_PATH);
Tcl_DStringInit(&ds);
strcpy(fullName, Tcl_WCharToUtfDString(nativeFullPath, TCL_INDEX_NONE, &ds));
Tcl_DStringFree(&ds);
}
return applType;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1533 1534 1535 1536 1537 1538 1539 |
return special;
}
static void
BuildCommandLine(
const char *executable, /* Full path of executable (including
* extension). Replacement for argv[0]. */
| | | > | 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 |
return special;
}
static void
BuildCommandLine(
const char *executable, /* Full path of executable (including
* extension). Replacement for argv[0]. */
size_t argc, /* Number of arguments. */
const char **argv, /* Argument strings in UTF. */
Tcl_DString *linePtr) /* Initialized Tcl_DString that receives the
* command line (WCHAR). */
{
const char *arg, *start, *special, *bspos;
int quote = 0;
size_t i;
Tcl_DString ds;
static const char specMetaChars[] = "&|^<>!()%";
/* Characters to enclose in quotes if unpaired
* quote flag set. */
static const char specMetaChars2[] = "%";
/* Character to enclose in quotes in any case
* (regardless of unpaired-flag). */
|
| ︙ | ︙ | |||
1625 1626 1627 1628 1629 1630 1631 |
TclDStringAppendLiteral(&ds, "\"");
}
if (!(quote & CL_ESCAPE)) {
/*
* Nothing to escape.
*/
| | | 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 |
TclDStringAppendLiteral(&ds, "\"");
}
if (!(quote & CL_ESCAPE)) {
/*
* Nothing to escape.
*/
Tcl_DStringAppend(&ds, arg, TCL_INDEX_NONE);
} else {
start = arg;
for (special = arg; *special != '\0'; ) {
/*
* Position of `\` is important before quote or at end (equal
* `\"` because quoted).
*/
|
| ︙ | ︙ |
Changes to win/tclWinPort.h.
| ︙ | ︙ | |||
454 455 456 457 458 459 460 461 462 463 464 465 466 467 | # undef EDEADLOCK # if defined(_MSC_VER) # define timezone _timezone # endif #endif /* _MSC_VER || __MSVCRT__ */ #if defined(_MSC_VER) # pragma warning(disable:4146) # pragma warning(disable:4244) #if !defined(_WIN64) # pragma warning(disable:4305) #endif # pragma warning(disable:4267) # pragma warning(disable:4996) | > | 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 | # undef EDEADLOCK # if defined(_MSC_VER) # define timezone _timezone # endif #endif /* _MSC_VER || __MSVCRT__ */ #if defined(_MSC_VER) # pragma warning(disable:4090) /* see: https://developercommunity.visualstudio.com/t/c-compiler-incorrect-propagation-of-const-qualifie/390711 */ # pragma warning(disable:4146) # pragma warning(disable:4244) #if !defined(_WIN64) # pragma warning(disable:4305) #endif # pragma warning(disable:4267) # pragma warning(disable:4996) |
| ︙ | ︙ |
Changes to win/tclWinSerial.c.
| ︙ | ︙ | |||
281 282 283 284 285 286 287 | * Removes the serial event source. * *---------------------------------------------------------------------- */ static void SerialExitHandler( | | | 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 |
* Removes the serial event source.
*
*----------------------------------------------------------------------
*/
static void
SerialExitHandler(
TCL_UNUSED(void *))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
SerialInfo *infoPtr;
/*
* Clear all eventually pending output. Otherwise Tcl's exit could totally
* block, because it performs a blocking flush on all open channels. Note
|
| ︙ | ︙ | |||
319 320 321 322 323 324 325 | * Resets the process list. * *---------------------------------------------------------------------- */ static void ProcExitHandler( | | | 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 |
* Resets the process list.
*
*----------------------------------------------------------------------
*/
static void
ProcExitHandler(
TCL_UNUSED(void *))
{
Tcl_MutexLock(&serialMutex);
initialized = 0;
Tcl_MutexUnlock(&serialMutex);
}
/*
|
| ︙ | ︙ | |||
402 403 404 405 406 407 408 | #ifdef __cplusplus #define min(a, b) (((a) < (b)) ? (a) : (b)) #endif void SerialSetupProc( | | | 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 |
#ifdef __cplusplus
#define min(a, b) (((a) < (b)) ? (a) : (b))
#endif
void
SerialSetupProc(
TCL_UNUSED(void *),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
SerialInfo *infoPtr;
int block = 1;
int msec = INT_MAX; /* min. found block time */
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
457 458 459 460 461 462 463 | * May queue an event. * *---------------------------------------------------------------------- */ static void SerialCheckProc( | | | 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 |
* May queue an event.
*
*----------------------------------------------------------------------
*/
static void
SerialCheckProc(
TCL_UNUSED(void *),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
SerialInfo *infoPtr;
SerialEvent *evPtr;
int needEvent;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
COMSTAT cStat;
|
| ︙ | ︙ | |||
1626 1627 1628 1629 1630 1631 1632 |
{
SerialInfo *infoPtr;
DCB dcb;
BOOL result, flag;
size_t len, vlen;
Tcl_DString ds;
const WCHAR *native;
| | | 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 |
{
SerialInfo *infoPtr;
DCB dcb;
BOOL result, flag;
size_t len, vlen;
Tcl_DString ds;
const WCHAR *native;
size_t argc;
const char **argv;
infoPtr = (SerialInfo *) instanceData;
/*
* Parse options. This would be far easier if we had Tcl_Objs to work with
* as that would let us use Tcl_GetIndexFromObj()...
|
| ︙ | ︙ | |||
1674 1675 1676 1677 1678 1679 1680 |
*/
if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) {
if (!GetCommState(infoPtr->handle, &dcb)) {
goto getStateFailed;
}
Tcl_DStringInit(&ds);
| | | 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 |
*/
if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) {
if (!GetCommState(infoPtr->handle, &dcb)) {
goto getStateFailed;
}
Tcl_DStringInit(&ds);
native = Tcl_UtfToWCharDString(value, TCL_INDEX_NONE, &ds);
result = BuildCommDCBW(native, &dcb);
Tcl_DStringFree(&ds);
if (result == FALSE) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad value \"%s\" for -mode: should be baud,parity,data,stop",
|
| ︙ | ︙ | |||
1775 1776 1777 1778 1779 1780 1781 |
return TCL_ERROR;
}
if (argc != 2) {
badXchar:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -xchar: should be a list of"
| | | 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 |
return TCL_ERROR;
}
if (argc != 2) {
badXchar:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -xchar: should be a list of"
" two elements with each a single 8-bit character", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL);
}
Tcl_Free((void *)argv);
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
1822 1823 1824 1825 1826 1827 1828 |
}
/*
* Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
*/
if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) {
| > | | 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 |
}
/*
* Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
*/
if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) {
size_t i;
int res = TCL_OK;
if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
}
if ((argc % 2) == 1) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
| ︙ | ︙ | |||
1848 1849 1850 1851 1852 1853 1854 |
break;
}
if (strncasecmp(argv[i], "DTR", strlen(argv[i])) == 0) {
if (!EscapeCommFunction(infoPtr->handle,
(DWORD) (flag ? SETDTR : CLRDTR))) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | | | 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 1879 1880 1881 1882 1883 1884 1885 1886 1887 |
break;
}
if (strncasecmp(argv[i], "DTR", strlen(argv[i])) == 0) {
if (!EscapeCommFunction(infoPtr->handle,
(DWORD) (flag ? SETDTR : CLRDTR))) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't set DTR signal", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
"FCONFIGURE", "TTY_SIGNAL", NULL);
}
res = TCL_ERROR;
break;
}
} else if (strncasecmp(argv[i], "RTS", strlen(argv[i])) == 0) {
if (!EscapeCommFunction(infoPtr->handle,
(DWORD) (flag ? SETRTS : CLRRTS))) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't set RTS signal", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
"FCONFIGURE", "TTY_SIGNAL", NULL);
}
res = TCL_ERROR;
break;
}
} else if (strncasecmp(argv[i], "BREAK", strlen(argv[i])) == 0) {
if (!EscapeCommFunction(infoPtr->handle,
(DWORD) (flag ? SETBREAK : CLRBREAK))) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't set BREAK signal", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
"FCONFIGURE", "TTY_SIGNAL", NULL);
}
res = TCL_ERROR;
break;
}
} else {
|
| ︙ | ︙ |
Changes to win/tclWinSock.c.
| ︙ | ︙ | |||
121 122 123 124 125 126 127 |
TcpState *statePtr;
SOCKET fd;
struct TcpFdList *next;
} TcpFdList;
struct TcpState {
Tcl_Channel channel; /* Channel associated with this socket. */
| < < < > | | 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 |
TcpState *statePtr;
SOCKET fd;
struct TcpFdList *next;
} TcpFdList;
struct TcpState {
Tcl_Channel channel; /* Channel associated with this socket. */
int flags; /* Bit field comprised of the flags described
* below. */
struct TcpFdList *sockets; /* Windows SOCKET handle. */
int watchEvents; /* OR'ed combination of FD_READ, FD_WRITE,
* FD_CLOSE, FD_ACCEPT and FD_CONNECT that
* indicate which events are interesting. */
volatile int readyEvents; /* OR'ed combination of FD_READ, FD_WRITE,
* FD_CLOSE, FD_ACCEPT and FD_CONNECT that
* indicate which events have occurred.
* Set by notifier thread, access must be
* protected by semaphore */
int selectEvents; /* OR'ed combination of FD_READ, FD_WRITE,
* FD_CLOSE, FD_ACCEPT and FD_CONNECT that
* indicate which events are currently being
* selected. */
volatile int acceptEventCount;
/* Count of the current number of FD_ACCEPTs
* that have arrived and not yet processed.
* Set by notifier thread, access must be
* protected by semaphore */
Tcl_TcpAcceptProc *acceptProc;
/* Proc to call on accept. */
void *acceptProcData; /* The data for the accept proc. */
/*
* Only needed for client sockets
*/
struct addrinfo *addrlist; /* Addresses to connect to. */
struct addrinfo *addr; /* Iterator over addrlist. */
|
| ︙ | ︙ | |||
182 183 184 185 186 187 188 | * socket */ #define TCP_ASYNC_PENDING (1<<4) /* TcpConnect was called to * process an async connect. This * flag indicates that reentry is * still pending */ #define TCP_ASYNC_FAILED (1<<5) /* An async connect finally failed */ | < < < < < | | 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 | * socket */ #define TCP_ASYNC_PENDING (1<<4) /* TcpConnect was called to * process an async connect. This * flag indicates that reentry is * still pending */ #define TCP_ASYNC_FAILED (1<<5) /* An async connect finally failed */ #define TCP_ASYNC_TEST_MODE (1<<8) /* Async testing activated. Do not * automatically continue connection * process */ /* * The following structure is what is added to the Tcl event queue when a * socket event occurs. */ |
| ︙ | ︙ | |||
241 242 243 244 245 246 247 | * Static routines for this file: */ static int TcpConnect(Tcl_Interp *interp, TcpState *state); static void InitSockets(void); static TcpState * NewSocketInfo(SOCKET socket); | | | | 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 | * Static routines for this file: */ static int TcpConnect(Tcl_Interp *interp, TcpState *state); static void InitSockets(void); static TcpState * NewSocketInfo(SOCKET socket); static void SocketExitHandler(void *clientData); static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam); static int SocketsEnabled(void); static void TcpAccept(TcpFdList *fds, SOCKET newSocket, address addr); static int WaitForConnect(TcpState *statePtr, int *errorCodePtr); static int WaitForSocketEvent(TcpState *statePtr, int events, int *errorCodePtr); static void AddSocketInfoFd(TcpState *statePtr, SOCKET socket); static int FindFDInList(TcpState *statePtr, SOCKET socket); static DWORD WINAPI SocketThread(LPVOID arg); static void TcpThreadActionProc(void *instanceData, int action); static int TcpCloseProc(void *, Tcl_Interp *); static Tcl_EventCheckProc SocketCheckProc; static Tcl_EventProc SocketEventProc; static Tcl_EventSetupProc SocketSetupProc; static Tcl_DriverBlockModeProc TcpBlockModeProc; |
| ︙ | ︙ | |||
369 370 371 372 373 374 375 |
Tcl_DStringInit(&ds);
if (GetComputerNameExW(ComputerNamePhysicalDnsFullyQualified, wbuf, &length) != 0) {
/*
* Convert string from native to UTF then change to lowercase.
*/
| | | | | 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 |
Tcl_DStringInit(&ds);
if (GetComputerNameExW(ComputerNamePhysicalDnsFullyQualified, wbuf, &length) != 0) {
/*
* Convert string from native to UTF then change to lowercase.
*/
Tcl_UtfToLower(Tcl_WCharToUtfDString(wbuf, TCL_INDEX_NONE, &ds));
} else {
if (TclpHasSockets(NULL) == TCL_OK) {
/*
* The buffer size of 256 is recommended by the MSDN page that
* documents gethostname() as being always adequate.
*/
Tcl_DString inDs;
Tcl_DStringInit(&inDs);
Tcl_DStringSetLength(&inDs, 256);
if (gethostname(Tcl_DStringValue(&inDs),
Tcl_DStringLength(&inDs)) == 0) {
Tcl_ExternalToUtfDStringEx(NULL, Tcl_DStringValue(&inDs),
TCL_INDEX_NONE, TCL_ENCODING_NOCOMPLAIN, &ds);
}
Tcl_DStringFree(&inDs);
}
}
*encodingPtr = Tcl_GetEncoding(NULL, "utf-8");
*lengthPtr = Tcl_DStringLength(&ds);
|
| ︙ | ︙ | |||
458 459 460 461 462 463 464 |
Tcl_MutexUnlock(&socketMutex);
if (SocketsEnabled()) {
return TCL_OK;
}
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| | | 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 |
Tcl_MutexUnlock(&socketMutex);
if (SocketsEnabled()) {
return TCL_OK;
}
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"sockets are not available on this system", TCL_INDEX_NONE));
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
540 541 542 543 544 545 546 | * Sets the device into blocking or nonblocking mode. * *---------------------------------------------------------------------- */ static int TcpBlockModeProc( | | | | 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 |
* Sets the device into blocking or nonblocking mode.
*
*----------------------------------------------------------------------
*/
static int
TcpBlockModeProc(
void *instanceData, /* Socket state. */
int mode) /* The mode to set. Can be one of
* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
TcpState *statePtr = (TcpState *)instanceData;
if (mode == TCL_MODE_NONBLOCKING) {
SET_BITS(statePtr->flags, TCP_NONBLOCKING);
} else {
CLEAR_BITS(statePtr->flags, TCP_NONBLOCKING);
}
return 0;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
581 582 583 584 585 586 587 | * * Results: * 0 if the connection has completed, -1 if still in progress or there is * an error. * * Side effects: * Processes socket events off the system queue. May process | | | 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 |
*
* Results:
* 0 if the connection has completed, -1 if still in progress or there is
* an error.
*
* Side effects:
* Processes socket events off the system queue. May process
* asynchronous connect.
*
*----------------------------------------------------------------------
*/
static int
WaitForConnect(
TcpState *statePtr, /* State of the socket. */
|
| ︙ | ︙ | |||
622 623 624 625 626 627 628 |
* In socket test mode do not continue with the connect
* Exceptions are:
* - Call by recv/send and blocking socket
* (errorCodePtr != NULL && !GOT_BITS(flags, TCP_NONBLOCKING))
* - Call by the event queue (errorCodePtr == NULL)
*/
| | | 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 |
* In socket test mode do not continue with the connect
* Exceptions are:
* - Call by recv/send and blocking socket
* (errorCodePtr != NULL && !GOT_BITS(flags, TCP_NONBLOCKING))
* - Call by the event queue (errorCodePtr == NULL)
*/
if (GOT_BITS(statePtr->flags, TCP_ASYNC_TEST_MODE)
&& errorCodePtr != NULL
&& GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) {
*errorCodePtr = EWOULDBLOCK;
return -1;
}
/*
|
| ︙ | ︙ | |||
648 649 650 651 652 653 654 | * Get the statePtr lock. */ tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); WaitForSingleObject(tsdPtr->socketListLock, INFINITE); /* | | | | | | | | | | 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 |
* Get the statePtr lock.
*/
tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
/*
* Check for connect event.
*/
if (GOT_BITS(statePtr->readyEvents, FD_CONNECT)) {
/*
* Consume the connect event.
*/
CLEAR_BITS(statePtr->readyEvents, FD_CONNECT);
/*
* For blocking sockets and foreground processing, disable async
* connect as we continue now synchoneously.
*/
if (errorCodePtr != NULL &&
!GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) {
CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
}
/*
* Free list lock.
*/
SetEvent(tsdPtr->socketListLock);
/*
* Continue connect. If switched to synchroneous connect, the
* connect is terminated.
*/
result = TcpConnect(NULL, statePtr);
/*
* Restore event service mode.
*/
(void) Tcl_SetServiceMode(oldMode);
/*
* Check for Succesfull connect or async connect restart
*/
|
| ︙ | ︙ | |||
771 772 773 774 775 776 777 | * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ static int TcpInputProc( | | | 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 |
* Reads input from the input device of the channel.
*
*----------------------------------------------------------------------
*/
static int
TcpInputProc(
void *instanceData, /* Socket state. */
char *buf, /* Where to store data read. */
int bufSize, /* How much space is available in the
* buffer? */
int *errorCodePtr) /* Where to store error code. */
{
TcpState *statePtr = (TcpState *)instanceData;
int bytesRead;
|
| ︙ | ︙ | |||
826 827 828 829 830 831 832 |
* using non-blocking sockets.
*/
while (1) {
SendSelectMessage(tsdPtr, UNSELECT, statePtr);
/*
| | | | | 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 |
* using non-blocking sockets.
*/
while (1) {
SendSelectMessage(tsdPtr, UNSELECT, statePtr);
/*
* Single fd operation: this proc is only called for a connected
* socket.
*/
bytesRead = recv(statePtr->sockets->fd, buf, bufSize, 0);
CLEAR_BITS(statePtr->readyEvents, FD_READ);
/*
* Check for end-of-file condition or successful read.
*/
|
| ︙ | ︙ | |||
873 874 875 876 877 878 879 | } /* * Check for error condition or underflow in non-blocking case. */ if (GOT_BITS(statePtr->flags, TCP_NONBLOCKING) | | | 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 |
}
/*
* Check for error condition or underflow in non-blocking case.
*/
if (GOT_BITS(statePtr->flags, TCP_NONBLOCKING)
|| (error != WSAEWOULDBLOCK)) {
Tcl_WinConvertError(error);
*errorCodePtr = Tcl_GetErrno();
bytesRead = -1;
break;
}
/*
|
| ︙ | ︙ | |||
915 916 917 918 919 920 921 | * Produces output on the socket. * *---------------------------------------------------------------------- */ static int TcpOutputProc( | | | 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 |
* Produces output on the socket.
*
*----------------------------------------------------------------------
*/
static int
TcpOutputProc(
void *instanceData, /* Socket state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCodePtr) /* Where to store error code. */
{
TcpState *statePtr = (TcpState *)instanceData;
int written;
DWORD error;
|
| ︙ | ︙ | |||
952 953 954 955 956 957 958 |
return -1;
}
while (1) {
SendSelectMessage(tsdPtr, UNSELECT, statePtr);
/*
| | | | | 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 |
return -1;
}
while (1) {
SendSelectMessage(tsdPtr, UNSELECT, statePtr);
/*
* Single fd operation: this proc is only called for a connected
* socket.
*/
written = send(statePtr->sockets->fd, buf, toWrite, 0);
if (written != SOCKET_ERROR) {
/*
* Since Windows won't generate a new write event until we hit an
* overflow condition, we need to force the event loop to poll
* until the condition changes.
|
| ︙ | ︙ | |||
1030 1031 1032 1033 1034 1035 1036 | * Closes the socket. * *---------------------------------------------------------------------- */ static int TcpCloseProc( | | | 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 |
* Closes the socket.
*
*----------------------------------------------------------------------
*/
static int
TcpCloseProc(
void *instanceData, /* The socket to close. */
TCL_UNUSED(Tcl_Interp *))
{
TcpState *statePtr = (TcpState *)instanceData;
/* TIP #218 */
int errorCode = 0;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
1080 1081 1082 1083 1084 1085 1086 |
* This may be called, if an async socket connect fails or is closed
* between connect and thread action callback.
*/
if (tsdPtr->pendingTcpState != NULL
&& tsdPtr->pendingTcpState == statePtr) {
/*
| | | | | | 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 |
* This may be called, if an async socket connect fails or is closed
* between connect and thread action callback.
*/
if (tsdPtr->pendingTcpState != NULL
&& tsdPtr->pendingTcpState == statePtr) {
/*
* Get infoPtr lock, because this concerns the notifier thread.
*/
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
tsdPtr->pendingTcpState = NULL;
/*
* Free list lock.
*/
SetEvent(tsdPtr->socketListLock);
}
/*
* TIP #218. Removed the code removing the structure from the global
* socket list. This is now done by the thread action callbacks, and only
|
| ︙ | ︙ | |||
1124 1125 1126 1127 1128 1129 1130 | * Shuts down one side of the socket. * *---------------------------------------------------------------------- */ static int TcpClose2Proc( | | | 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 |
* Shuts down one side of the socket.
*
*----------------------------------------------------------------------
*/
static int
TcpClose2Proc(
void *instanceData, /* The socket to close. */
Tcl_Interp *interp, /* For error reporting. */
int flags) /* Flags that indicate which side to close. */
{
TcpState *statePtr = (TcpState *)instanceData;
int readError = 0;
int writeError = 0;
|
| ︙ | ︙ | |||
1174 1175 1176 1177 1178 1179 1180 | * Changes attributes of the socket at the system level. * *---------------------------------------------------------------------- */ static int TcpSetOptionProc( | | | 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 |
* Changes attributes of the socket at the system level.
*
*----------------------------------------------------------------------
*/
static int
TcpSetOptionProc(
void *instanceData, /* Socket state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Name of the option to set. */
TCL_UNUSED(const char *) /*value*/) /* New value for option. */
{
#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
TcpState *statePtr = instanceData;
SOCKET sock;
|
| ︙ | ︙ | |||
1279 1280 1281 1282 1283 1284 1285 | * None. * *---------------------------------------------------------------------- */ static int TcpGetOptionProc( | | | 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TcpGetOptionProc(
void *instanceData, /* Socket state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Name of the option to retrieve the value
* for, or NULL to get all options and their
* values. */
Tcl_DString *dsPtr) /* Where to store the computed value;
* initialized by caller. */
{
|
| ︙ | ︙ | |||
1315 1316 1317 1318 1319 1320 1321 |
/*
* Go one step in async connect
*
* If any error is thrown save it as backround error to report eventually
* below.
*/
| | | | | 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 |
/*
* Go one step in async connect
*
* If any error is thrown save it as backround error to report eventually
* below.
*/
if (!GOT_BITS(statePtr->flags, TCP_ASYNC_TEST_MODE)) {
WaitForConnect(statePtr, NULL);
}
sock = statePtr->sockets->fd;
if (optionName != NULL) {
len = strlen(optionName);
}
if ((len > 1) && (optionName[1] == 'e') &&
(strncmp(optionName, "-error", len) == 0)) {
/*
* Do not return any errors if async connect is running.
*/
if (!GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) {
if (GOT_BITS(statePtr->flags, TCP_ASYNC_FAILED)) {
/*
* In case of a failed async connect, eventually report the
* connect error only once. Do not report the system error,
* as this comes again and again.
|
| ︙ | ︙ | |||
1375 1376 1377 1378 1379 1380 1381 |
/*
* Return error message.
*/
if (err) {
Tcl_WinConvertError(err);
| | < | | | 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 |
/*
* Return error message.
*/
if (err) {
Tcl_WinConvertError(err);
Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1);
}
}
}
return TCL_OK;
}
if ((len > 1) && (optionName[1] == 'c') &&
(strncmp(optionName, "-connecting", len) == 0)) {
Tcl_DStringAppend(dsPtr,
GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)
? "1" : "0", -1);
return TCL_OK;
}
if (interp != NULL
&& Tcl_GetVar(interp, SUPPRESS_RDNS_VAR, 0) != NULL) {
reverseDNS = NI_NUMERICHOST;
}
if ((len == 0) || ((len > 1) && (optionName[1] == 'p') &&
(strncmp(optionName, "-peername", len) == 0))) {
address peername;
socklen_t size = sizeof(peername);
if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) {
/*
* In async connect output an empty string
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-peername");
Tcl_DStringAppendElement(dsPtr, "");
} else {
return TCL_OK;
}
} else if (getpeername(sock, (LPSOCKADDR) &(peername.sa),
&size) == 0) {
/*
* Peername fetch succeeded - output list
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-peername");
Tcl_DStringStartSublist(dsPtr);
|
| ︙ | ︙ | |||
1471 1472 1473 1474 1475 1476 1477 |
Tcl_DStringStartSublist(dsPtr);
}
if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) {
/*
* In async connect output an empty string
*/
| | | 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 |
Tcl_DStringStartSublist(dsPtr);
}
if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) {
/*
* In async connect output an empty string
*/
found = 1;
} else {
for (fds = statePtr->sockets; fds != NULL; fds = fds->next) {
sock = fds->fd;
size = sizeof(sockname);
if (getsockname(sock, &(sockname.sa), &size) >= 0) {
int flags = reverseDNS;
|
| ︙ | ︙ | |||
1601 1602 1603 1604 1605 1606 1607 | * already true. * *---------------------------------------------------------------------- */ static void TcpWatchProc( | | | 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 |
* already true.
*
*----------------------------------------------------------------------
*/
static void
TcpWatchProc(
void *instanceData, /* The socket state. */
int mask) /* Events of interest; an OR-ed combination of
* TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
TcpState *statePtr = (TcpState *)instanceData;
/*
|
| ︙ | ︙ | |||
1655 1656 1657 1658 1659 1660 1661 | * None. * *---------------------------------------------------------------------- */ static int TcpGetHandleProc( | | | | 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TcpGetHandleProc(
void *instanceData, /* The socket state. */
TCL_UNUSED(int) /*direction*/,
void **handlePtr) /* Where to store the handle. */
{
TcpState *statePtr = (TcpState *)instanceData;
*handlePtr = INT2PTR(statePtr->sockets->fd);
return TCL_OK;
}
|
| ︙ | ︙ | |||
1724 1725 1726 1727 1728 1729 1730 |
if (async_callback) {
goto reenter;
}
for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL;
statePtr->addr = statePtr->addr->ai_next) {
| | | | | | | | | | | | | | | | | 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 |
if (async_callback) {
goto reenter;
}
for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL;
statePtr->addr = statePtr->addr->ai_next) {
for (statePtr->myaddr = statePtr->myaddrlist;
statePtr->myaddr != NULL;
statePtr->myaddr = statePtr->myaddr->ai_next) {
/*
* No need to try combinations of local and remote addresses
* of different families.
*/
if (statePtr->myaddr->ai_family != statePtr->addr->ai_family) {
continue;
}
/*
* Close the socket if it is still open from the last unsuccessful
* iteration.
*/
if (statePtr->sockets->fd != INVALID_SOCKET) {
closesocket(statePtr->sockets->fd);
}
/*
* Get statePtr lock.
*/
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
/*
* Reset last error from last try
*/
statePtr->notifierConnectError = 0;
Tcl_SetErrno(0);
statePtr->sockets->fd = socket(statePtr->myaddr->ai_family,
SOCK_STREAM, 0);
/*
* Free list lock.
*/
SetEvent(tsdPtr->socketListLock);
/*
* Continue on socket creation error.
*/
if (statePtr->sockets->fd == INVALID_SOCKET) {
Tcl_WinConvertError((DWORD) WSAGetLastError());
continue;
}
/*
* Win-NT has a misfeature that sockets are inherited in child
* processes by default. Turn off the inherit bit.
*/
SetHandleInformation((HANDLE) statePtr->sockets->fd,
HANDLE_FLAG_INHERIT, 0);
/*
* Set kernel space buffering
*/
TclSockMinimumBuffers((void *) statePtr->sockets->fd,
TCP_BUFFER_SIZE);
/*
* Try to bind to a local port.
*/
if (bind(statePtr->sockets->fd, statePtr->myaddr->ai_addr,
statePtr->myaddr->ai_addrlen) == SOCKET_ERROR) {
Tcl_WinConvertError((DWORD) WSAGetLastError());
continue;
}
/*
* For asynchronous connect set the socket in nonblocking mode
* and activate connect notification
*/
if (async_connect) {
TcpState *statePtr2;
int in_socket_list = 0;
/*
* Get statePtr lock.
*/
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
/*
* Bugfig for 336441ed59 to not ignore notifications until the
* infoPtr is in the list.
* Check if my statePtr is already in the tsdPtr->socketList
|
| ︙ | ︙ | |||
1840 1841 1842 1843 1844 1845 1846 |
}
if (!in_socket_list) {
tsdPtr->pendingTcpState = statePtr;
}
/*
* Set connect mask to connect events
| | | | | | 1832 1833 1834 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 |
}
if (!in_socket_list) {
tsdPtr->pendingTcpState = statePtr;
}
/*
* Set connect mask to connect events
*
* This is activated by a SOCKET_SELECT message to the
* notifier thread.
*/
SET_BITS(statePtr->selectEvents, FD_CONNECT);
/*
* Free list lock.
*/
SetEvent(tsdPtr->socketListLock);
/*
* Activate accept notification.
*/
SendSelectMessage(tsdPtr, SELECT, statePtr);
}
/*
* Attempt to connect to the remote socket.
*/
|
| ︙ | ︙ | |||
1891 1892 1893 1894 1895 1896 1897 | * * Clear the reenter flag */ CLEAR_BITS(statePtr->flags, TCP_ASYNC_PENDING); /* | | | | | | | | | | | 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 |
*
* Clear the reenter flag
*/
CLEAR_BITS(statePtr->flags, TCP_ASYNC_PENDING);
/*
* Get statePtr lock.
*/
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
/*
* Get signaled connect error.
*/
Tcl_WinConvertError((DWORD) statePtr->notifierConnectError);
/*
* Clear eventual connect flag.
*/
CLEAR_BITS(statePtr->selectEvents, FD_CONNECT);
/*
* Free list lock.
*/
SetEvent(tsdPtr->socketListLock);
}
/*
* Clear the tsd socket list pointer if we did not wait for
* the FD_CONNECT asynchronously
*/
tsdPtr->pendingTcpState = NULL;
if (Tcl_GetErrno() == 0) {
goto out;
}
|
| ︙ | ︙ | |||
1969 1970 1971 1972 1973 1974 1975 | /* * Set up the select mask for read/write events. */ statePtr->selectEvents = FD_WRITE|FD_READ; /* | | | | | | | | | | | | 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 | /* * Set up the select mask for read/write events. */ statePtr->selectEvents = FD_WRITE|FD_READ; /* * Get statePtr lock. */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); /* * Signal ready readable and writable events. */ SET_BITS(statePtr->readyEvents, FD_WRITE | FD_READ); /* * Flag error to event routine. */ SET_BITS(statePtr->flags, TCP_ASYNC_FAILED); /* * Save connect error to be reported by 'fconfigure -error'. */ statePtr->connectError = Tcl_GetErrno(); /* * Free list lock. */ SetEvent(tsdPtr->socketListLock); } /* * Error message on synchroneous connect */ |
| ︙ | ︙ | |||
2125 2126 2127 2128 2129 2130 2131 | * None. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_MakeTcpClientChannel( | | | 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 |
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_MakeTcpClientChannel(
void *sock) /* The socket to wrap up into a channel. */
{
TcpState *statePtr;
char channelName[SOCK_CHAN_LENGTH];
ThreadSpecificData *tsdPtr;
if (TclpHasSockets(NULL) != TCL_OK) {
return NULL;
|
| ︙ | ︙ | |||
2185 2186 2187 2188 2189 2190 2191 |
Tcl_Interp *interp, /* For error reporting - may be NULL. */
const char *service, /* Port number to open. */
const char *myHost, /* Name of local host. */
unsigned int flags, /* Flags. */
Tcl_TcpAcceptProc *acceptProc,
/* Callback for accepting connections from new
* clients. */
| | | 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 |
Tcl_Interp *interp, /* For error reporting - may be NULL. */
const char *service, /* Port number to open. */
const char *myHost, /* Name of local host. */
unsigned int flags, /* Flags. */
Tcl_TcpAcceptProc *acceptProc,
/* Callback for accepting connections from new
* clients. */
void *acceptProcData) /* Data for the callback. */
{
SOCKET sock = INVALID_SOCKET;
unsigned short chosenport = 0;
struct addrinfo *addrlist = NULL;
struct addrinfo *addrPtr; /* Socket address to listen on. */
TcpState *statePtr = NULL; /* The returned value. */
char channelName[SOCK_CHAN_LENGTH];
|
| ︙ | ︙ | |||
2221 2222 2223 2224 2225 2226 2227 |
if (TclSockGetPort(interp, service, "tcp", &port) != TCL_OK) {
errorMsg = "invalid port number";
goto error;
}
if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1,
| | | 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 |
if (TclSockGetPort(interp, service, "tcp", &port) != TCL_OK) {
errorMsg = "invalid port number";
goto error;
}
if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1,
&errorMsg)) {
goto error;
}
for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) {
sock = socket(addrPtr->ai_family, addrPtr->ai_socktype,
addrPtr->ai_protocol);
if (sock == INVALID_SOCKET) {
|
| ︙ | ︙ | |||
2279 2280 2281 2282 2283 2284 2285 | * * Bind should not be affected by the socket having already been * set into nonblocking mode. If there is trouble, this is one * place to look for bugs. */ if (bind(sock, addrPtr->ai_addr, | | | 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 |
*
* Bind should not be affected by the socket having already been
* set into nonblocking mode. If there is trouble, this is one
* place to look for bugs.
*/
if (bind(sock, addrPtr->ai_addr,
addrPtr->ai_addrlen) == SOCKET_ERROR) {
Tcl_WinConvertError((DWORD) WSAGetLastError());
closesocket(sock);
continue;
}
if (port == 0 && chosenport == 0) {
address sockname;
socklen_t namelen = sizeof(sockname);
|
| ︙ | ︙ | |||
2602 2603 2604 2605 2606 2607 2608 | * None. * *---------------------------------------------------------------------- */ static void SocketExitHandler( | | | 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 |
* None.
*
*----------------------------------------------------------------------
*/
static void
SocketExitHandler(
TCL_UNUSED(void *))
{
Tcl_MutexLock(&socketMutex);
/*
* Make sure the socket event handling window is cleaned-up for, at
* most, this thread.
*/
|
| ︙ | ︙ | |||
2636 2637 2638 2639 2640 2641 2642 | * Adjusts the block time if needed. * *---------------------------------------------------------------------- */ void SocketSetupProc( | | | | 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 |
* Adjusts the block time if needed.
*
*----------------------------------------------------------------------
*/
void
SocketSetupProc(
TCL_UNUSED(void *),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
TcpState *statePtr;
Tcl_Time blockTime = { 0, 0 };
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!GOT_BITS(flags, TCL_FILE_EVENTS)) {
return;
}
/*
* Check to see if there is a ready socket. If so, poll.
*/
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
for (statePtr = tsdPtr->socketList; statePtr != NULL;
statePtr = statePtr->nextPtr) {
if (GOT_BITS(statePtr->readyEvents,
statePtr->watchEvents | FD_CONNECT | FD_ACCEPT)) {
Tcl_SetMaxBlockTime(&blockTime);
break;
}
}
SetEvent(tsdPtr->socketListLock);
}
|
| ︙ | ︙ | |||
2681 2682 2683 2684 2685 2686 2687 | * May queue an event. * *---------------------------------------------------------------------- */ static void SocketCheckProc( | | | 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 |
* May queue an event.
*
*----------------------------------------------------------------------
*/
static void
SocketCheckProc(
TCL_UNUSED(void *),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
TcpState *statePtr;
SocketEvent *evPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!GOT_BITS(flags, TCL_FILE_EVENTS)) {
|
| ︙ | ︙ | |||
2811 2812 2813 2814 2815 2816 2817 |
/*
* Handle connection requests directly.
*/
if (GOT_BITS(statePtr->readyEvents, FD_ACCEPT)) {
for (fds = statePtr->sockets; fds != NULL; fds = fds->next) {
/*
| | | | | | 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 |
/*
* Handle connection requests directly.
*/
if (GOT_BITS(statePtr->readyEvents, FD_ACCEPT)) {
for (fds = statePtr->sockets; fds != NULL; fds = fds->next) {
/*
* Accept the incoming connection request.
*/
len = sizeof(address);
newSocket = accept(fds->fd, &(addr.sa), &len);
/*
* On Tcl server sockets with multiple OS fds we loop over the fds
* trying an accept() on each, so we expect INVALID_SOCKET. There
* are also other network stack conditions that can result in
* FD_ACCEPT but a subsequent failure on accept() by the time we
* get around to it.
*
* Access to sockets (acceptEventCount, readyEvents) in socketList
* is still protected by the lock (prevents reintroduction of
* SF Tcl Bug 3056775.
*/
if (newSocket == INVALID_SOCKET) {
/* int err = WSAGetLastError(); */
|
| ︙ | ︙ | |||
2849 2850 2851 2852 2853 2854 2855 |
if (statePtr->acceptEventCount <= 0) {
CLEAR_BITS(statePtr->readyEvents, FD_ACCEPT);
}
SetEvent(tsdPtr->socketListLock);
/*
| | | | 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 |
if (statePtr->acceptEventCount <= 0) {
CLEAR_BITS(statePtr->readyEvents, FD_ACCEPT);
}
SetEvent(tsdPtr->socketListLock);
/*
* Caution: TcpAccept() has the side-effect of evaluating the
* server accept script (via AcceptCallbackProc() in tclIOCmd.c),
* which can close the server socket and invalidate statePtr and
* fds. If TcpAccept() accepts a socket we must return immediately
* and let SocketCheckProc queue additional FD_ACCEPT events.
*/
TcpAccept(fds, newSocket, addr);
return 1;
}
/*
* Loop terminated with no sockets accepted; clear the ready mask so
* we can detect the next connection request. Note that connection
* requests are level triggered, so if there is a request already
* pending, a new event will be generated.
*/
statePtr->acceptEventCount = 0;
CLEAR_BITS(statePtr->readyEvents, FD_ACCEPT);
|
| ︙ | ︙ | |||
2977 2978 2979 2980 2981 2982 2983 |
TcpState *statePtr,
SOCKET socket)
{
TcpFdList *fds = statePtr->sockets;
if (fds == NULL) {
/*
| | | | | | 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 |
TcpState *statePtr,
SOCKET socket)
{
TcpFdList *fds = statePtr->sockets;
if (fds == NULL) {
/*
* Add the first FD.
*/
statePtr->sockets = (TcpFdList *)Tcl_Alloc(sizeof(TcpFdList));
fds = statePtr->sockets;
} else {
/*
* Find end of list and append FD.
*/
while (fds->next != NULL) {
fds = fds->next;
}
fds->next = (TcpFdList *)Tcl_Alloc(sizeof(TcpFdList));
fds = fds->next;
|
| ︙ | ︙ | |||
3086 3087 3088 3089 3090 3091 3092 |
SendSelectMessage(tsdPtr, UNSELECT, statePtr);
SendSelectMessage(tsdPtr, SELECT, statePtr);
while (1) {
int event_found;
/*
| | | | | | | | | | | | 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 |
SendSelectMessage(tsdPtr, UNSELECT, statePtr);
SendSelectMessage(tsdPtr, SELECT, statePtr);
while (1) {
int event_found;
/*
* Get statePtr lock.
*/
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
/*
* Check if event occured.
*/
event_found = GOT_BITS(statePtr->readyEvents, events);
/*
* Free list lock.
*/
SetEvent(tsdPtr->socketListLock);
/*
* Exit loop if event occured.
*/
if (event_found) {
break;
}
/*
* Exit loop if event did not occur but this is a non-blocking channel
*/
if (statePtr->flags & TCP_NONBLOCKING) {
*errorCodePtr = EWOULDBLOCK;
result = 0;
break;
}
|
| ︙ | ︙ | |||
3402 3403 3404 3405 3406 3407 3408 | * Changes thread local list of valid channels. * *---------------------------------------------------------------------- */ static void TcpThreadActionProc( | | | 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 |
* Changes thread local list of valid channels.
*
*----------------------------------------------------------------------
*/
static void
TcpThreadActionProc(
void *instanceData,
int action)
{
ThreadSpecificData *tsdPtr;
TcpState *statePtr = (TcpState *)instanceData;
int notifyCmd;
if (action == TCL_CHANNEL_THREAD_INSERT) {
|
| ︙ | ︙ |
Changes to win/tclWinTime.c.
| ︙ | ︙ | |||
104 105 106 107 108 109 110 |
} wideClick = {0, 0, 0.0};
/*
* Declarations for functions defined later in this file.
*/
| | | | | | 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 |
} wideClick = {0, 0, 0.0};
/*
* Declarations for functions defined later in this file.
*/
static void StopCalibration(void *clientData);
static DWORD WINAPI CalibrationThread(LPVOID arg);
static void UpdateTimeEachSecond(void);
static void ResetCounterSamples(unsigned long long fileTime,
long long perfCounter, long long perfFreq);
static long long AccumulateSample(long long perfCounter,
unsigned long long fileTime);
static void NativeScaleTime(Tcl_Time* timebuf,
void *clientData);
static long long NativeGetMicroseconds(void);
static void NativeGetTime(Tcl_Time* timebuf,
void *clientData);
/*
* TIP #233 (Virtualized Time): Data for the time hooks, if any.
*/
Tcl_GetTimeProc *tclGetTimeProcPtr = NativeGetTime;
Tcl_ScaleTimeProc *tclScaleTimeProcPtr = NativeScaleTime;
void *tclTimeClientData = NULL;
/*
* Inlined version of Tcl_GetTime.
*/
static inline void
GetTime(
|
| ︙ | ︙ | |||
407 408 409 410 411 412 413 |
*
*----------------------------------------------------------------------
*/
static void
NativeScaleTime(
TCL_UNUSED(Tcl_Time *),
| | | 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 |
*
*----------------------------------------------------------------------
*/
static void
NativeScaleTime(
TCL_UNUSED(Tcl_Time *),
TCL_UNUSED(void *))
{
/*
* Native scale is 1:1. Nothing is done.
*/
}
/*
|
| ︙ | ︙ | |||
673 674 675 676 677 678 679 |
*
*----------------------------------------------------------------------
*/
static void
NativeGetTime(
Tcl_Time *timePtr,
| | | 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 |
*
*----------------------------------------------------------------------
*/
static void
NativeGetTime(
Tcl_Time *timePtr,
TCL_UNUSED(void *))
{
long long usecSincePosixEpoch;
/*
* Try to use high resolution timer.
*/
|
| ︙ | ︙ | |||
720 721 722 723 724 725 726 | *---------------------------------------------------------------------- */ void TclWinResetTimerResolution(void); static void StopCalibration( | | | 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 |
*----------------------------------------------------------------------
*/
void TclWinResetTimerResolution(void);
static void
StopCalibration(
TCL_UNUSED(void *))
{
SetEvent(timeInfo.exitEvent);
/*
* If Tcl_Finalize was called from DllMain, the calibration thread is in a
* paused state so we need to timeout and continue.
*/
|
| ︙ | ︙ | |||
1194 1195 1196 1197 1198 1199 1200 |
*----------------------------------------------------------------------
*/
void
Tcl_SetTimeProc(
Tcl_GetTimeProc *getProc,
Tcl_ScaleTimeProc *scaleProc,
| | | 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 |
*----------------------------------------------------------------------
*/
void
Tcl_SetTimeProc(
Tcl_GetTimeProc *getProc,
Tcl_ScaleTimeProc *scaleProc,
void *clientData)
{
tclGetTimeProcPtr = getProc;
tclScaleTimeProcPtr = scaleProc;
tclTimeClientData = clientData;
}
/*
|
| ︙ | ︙ | |||
1221 1222 1223 1224 1225 1226 1227 |
*----------------------------------------------------------------------
*/
void
Tcl_QueryTimeProc(
Tcl_GetTimeProc **getProc,
Tcl_ScaleTimeProc **scaleProc,
| | | 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 |
*----------------------------------------------------------------------
*/
void
Tcl_QueryTimeProc(
Tcl_GetTimeProc **getProc,
Tcl_ScaleTimeProc **scaleProc,
void **clientData)
{
if (getProc) {
*getProc = tclGetTimeProcPtr;
}
if (scaleProc) {
*scaleProc = tclScaleTimeProcPtr;
}
|
| ︙ | ︙ |
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.3 |